![[Visual Basic] x Zahlen aus n Zahlen ziehen: Das Lotto-Problem](/data/resource_icons/0/4.jpg?1400925513){kind=icon}
Eine der am häufigsten gestellten Fragen, welche ich im Internet in diversen Foren gesehen habe, ist die Frage nach einem Algorithmus, welcher Folgendes abbildet:
Ziehung von x Zahlen aus n Zahlen ohne Zurücklegen und ohne Beachtung der Reihenfolge bei x<=n.
In verständliche Alltags-Worte übersetzt: Das berühmte Lotto-Problem.
Nachdem ich dann diverse Antworten, Vorschläge und ähnliches gesehen habe, unter denen auch teilweise, meiner Meinung nach, fürchterliche Algorithmus-Konstruktionen waren, habe ich mich hingesetzt, und selbst einen Algorithmus geschrieben.
Ich stelle meinen Algorithmus zur freien Verfügung. Über Feedback freue ich mich natürlich.
Hinweis: Quicksort wurde 1:1 von www.vbarchiv.net übernommen.
P.S.: Wenn mir jemand Alltags-Beispiele für Variante 2 und 4 nennen könnte, würde ich mich echt freuen. Mir ist absolut nichts dazu eingefallen.
Ziehung von x Zahlen aus n Zahlen ohne Zurücklegen und ohne Beachtung der Reihenfolge bei x<=n.
In verständliche Alltags-Worte übersetzt: Das berühmte Lotto-Problem.
Nachdem ich dann diverse Antworten, Vorschläge und ähnliches gesehen habe, unter denen auch teilweise, meiner Meinung nach, fürchterliche Algorithmus-Konstruktionen waren, habe ich mich hingesetzt, und selbst einen Algorithmus geschrieben.
Ich stelle meinen Algorithmus zur freien Verfügung. Über Feedback freue ich mich natürlich.
Hinweis: Quicksort wurde 1:1 von www.vbarchiv.net übernommen.
P.S.: Wenn mir jemand Alltags-Beispiele für Variante 2 und 4 nennen könnte, würde ich mich echt freuen. Mir ist absolut nichts dazu eingefallen.
Visual Basic:
'Ziel-Array
Public arrDest() As Long
Sub CallLottery()
'Aufruf
Lottery 6, 49, True, False 'ohne Beachtung der Reihenfolge und ohne Zurücklegen (Klassisches Lottospiel)
Lottery 6, 49, True, True 'ohne Beachtung der Reihenfolge jedoch mit Zurücklegen
Lottery 6, 49, False, False 'Mit Beachtung der Reihenfolge und ohne Zurücklegen (Tombola - Dritter, zweiter und Erster Platz u.ä.)
Lottery 6, 49, False, True 'Mit Beachtung der Reihenfolge jedoch mit Zurücklegen (Passwort-Generator)
End Sub
Public Sub Lottery(ByVal DrawNumbers As Long, ByVal TotalNumbers As Long, Optional ByVal Sorted As Boolean = True, Optional ByVal Duplicates As Boolean = False)
Dim arrSource() As Long
Dim i As Long
Dim UpperBound As Long
Dim Counter As Long
Dim RandomNumber As Long
'Quell und Source-Array gemäss Aufruf neu dimensionieren
ReDim arrDest(1 To DrawNumbers)
ReDim arrSource(1 To TotalNumbers)
'Aufbauen Quell-Array
For i = 1 To TotalNumbers
arrSource(i) = i
Next
Counter = 0
UpperBound = TotalNumbers
'Starte Zufallsgenerator
Randomize
Do
'Ziehe Zufallszahl
RandomNumber = Int(UpperBound * Rnd + 1)
Counter = Counter + 1 'Erhöhe Member-Index für Ziel-Array
'Nimm Zufallszahl als Index für das Quell-Array und weise dessen Wert dem aktuellen Member des Ziel-Arrays zu
arrDest(Counter) = arrSource(RandomNumber)
'Wird mit oder ohne Zurücklegen gezogen? Die If-Anweisung ergibt True falls ohne Zurücklegen gezogen wird
If Not Duplicates Then
'Ersetze gezogenes Mitglied des Quell-Arrays mit dem letzten "UpperBound" Mitglied des Quell-Arrays
arrSource(RandomNumber) = arrSource(UpperBound)
'Verkleinere "virtuell" das Quell-Array. Bereits gezogene Zahlen verschwinden aus dem Zufalls-Bereich
'Siehe "Ziehe Zufallszahl"
UpperBound = UpperBound - 1
End If
Loop Until Counter = DrawNumbers
'Wenn die Reihenfolge egal ist, springe zum sortieren
If Sorted Then QuickSort arrDest
End Sub
Public Sub QuickSort(vSort As Variant, _
Optional ByVal lngStart As Variant, _
Optional ByVal lngEnd As Variant)
' Wird die Bereichsgrenze nicht angegeben,
' so wird das gesamte Array sortiert
If IsMissing(lngStart) Then lngStart = LBound(vSort)
If IsMissing(lngEnd) Then lngEnd = UBound(vSort)
Dim i As Long
Dim j As Long
Dim h As Variant
Dim x As Variant
i = lngStart: j = lngEnd
x = vSort((lngStart + lngEnd) / 2)
' Array aufteilen
Do
While (vSort(i) < x): i = i + 1: Wend
While (vSort(j) > x): j = j - 1: Wend
If (i <= j) Then
' Wertepaare miteinander tauschen
h = vSort(i)
vSort(i) = vSort(j)
vSort(j) = h
i = i + 1: j = j - 1
End If
Loop Until (i > j)
' Rekursion (Funktion ruft sich selbst auf)
If (lngStart < j) Then QuickSort vSort, lngStart, j
If (i < lngEnd) Then QuickSort vSort, i, lngEnd
End Sub