Mehrmalige Stichprobe

[Alexandra123ize]

Habe es nun selbst mit Makros aus dem Internet und eigenen Makros zusammengewürfelt (Falls jemand das selbe machen möchte hier meine Lösung

PS: Bitte keine Vorwürfe, das war der erste Makro-Versuch meines Lebens Aber es hat geklappt

Sub AnzahlAnWiederholungen()
'Wiederhole die Makros unten 1000 mal
Dim i As Long
For i = 1 To 1000
Call Zufallswahl
Next
Call Stichprobennamen
End Sub

Sub Zufallswahl()
'Wähle 10 aus 50 durch Zufall
Dim x As Variant
With Worksheets("Data")
x = ZufallsinhaltAusBereich(.Range("A1:A50"), 10)
.Range(.Cells(2, 3), .Cells(UBound(x, 1), 3)) = x
End With
End Sub

Function ZufallsinhaltAusBereich(Quellbereich As Range, _
ByVal Anzahl As Long) As Variant
Dim varQuelle() As Variant
Dim avarGezogen() As Variant
Dim rngQuelle As Range
Dim lngMax As Long
Dim lngCount As Long
Dim lngZahl As Long
Dim colDoppelte As New Collection ' <Doppelte vermeiden>

ReDim varQuelle(1 To Quellbereich.Cells.Count)

' Pool erstellen
With Quellbereich
On Error Resume Next ' <Doppelte vermeiden>
For Each rngQuelle In Quellbereich
If rngQuelle.Value <> "" Then ' Leere vermeiden

' <Doppelte vermeiden>
Err.Clear
colDoppelte.Add lngCount, "X" & CStr(rngQuelle.Value)
If Err.Number = 0 Then
' </Doppelte vermeiden>

lngCount = lngCount + 1
varQuelle(lngCount) = rngQuelle.Value


End If ' <Doppelte vermeiden>
End If
Next
On Error GoTo 0 ' <Doppelte vermeiden>
End With

ReDim Preserve varQuelle(1 To lngCount)
If Anzahl > lngCount Then Anzahl = lngCount
ReDim avarGezogen(1 To Anzahl, 1 To 1)
lngMax = lngCount

' Wählen ohne Zurücklegen
Randomize Timer
For lngCount = lngMax To lngMax - Anzahl + 1 Step -1
lngZahl = Int((lngCount) * Rnd) + 1
avarGezogen(lngMax - lngCount + 1, 1) = varQuelle(lngZahl)
varQuelle(lngZahl) = varQuelle(lngCount)
Next

ZufallsinhaltAusBereich = avarGezogen

'Neue Spalte
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End Function

Sub Stichprobennamen()
'Stichprobe 1,2 ... 1000
Range("C1").Select
ActiveCell.FormulaR1C1 = "Stichprobe 1"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Stichprobe 2"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Stichprobe 3"
Range("C1:E1").Select
Selection.AutoFill Destination:=Range("C1:ALN1"), Type:=xlFillDefault
Range("C1:ALN1").Select
End Sub