04.08.2019, 19:35
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
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