AW: Zahlen fast zufällig erzeugen
05.09.2013 16:08:22
fcs
Hallo zeinz,
nachdem ich auch schon an einer Makro-Lösung gearbeitet hatte will ich sie dir auch nicht vorenthalten.
Das Prinzip ist ähnlich dem von Rudi, evtl. etwas komplizierter im Aufbau.
Ich verwende aber eine Hauptroutine in der die Vorgaben an eine Subroutine übergeben werden.
So kannst du problemlos verschiedene Varianten ausprobieren, indem du mehrere Hauptroutinne mit unterschiedlichen Parametern erstellst.
Gruß
Franz
Sub Zufall_0_9_15_x_10()
Call prcZufall_Zahlen_0_9(StartZelle:=ActiveSheet.Range("A20"), Zeilen:=15, _
Spalten:=10, Anz_0:=11, Anz_1:=18, Anz_2:=13, Anz_3:=22, Anz_4:=12, _
Anz_5:=15, Anz_6:=19, Anz_7:=16, Anz_8:=10, Anz_9:=14)
End Sub
Sub Zufall_0_9_15_x_26()
Call prcZufall_Zahlen_0_9(StartZelle:=ActiveSheet.Range("A2"), Zeilen:=15, _
Spalten:=26, Anz_0:=33, Anz_1:=31, Anz_2:=35, Anz_3:=34, Anz_4:=43, _
Anz_5:=36, Anz_6:=41, Anz_7:=44, Anz_8:=39, Anz_9:=54)
End Sub
Sub prcZufall_Zahlen_0_9(StartZelle As Range, Zeilen As Long, _
Spalten As Long, Anz_0%, Anz_1%, Anz_2%, Anz_3%, Anz_4&, Anz_5%, Anz_6%, _
Anz_7%, Anz_8%, Anz_9&, Optional lngLoopsMax As Long = 10000)
'lngLoopsMax gibt die max. Anzahl Do-Loop-Schleifen vor (Notausgang)
'typischer Weise sind 2000 bis 3000 Schleifen erforderlich um alle Zellen zu Füllen
Dim Zeile As Long, Spalte As Long, lngZahl As Long
Dim Zahlen() As Long, Zufallszahl As Long, ZufallsZelle As Long
Dim rngZahlen As Range
Dim AnzZellen As Long, lngCount As Long, StatusCalc As Long
Dim AnzahlZahl(0 To 9, 1 To 2) As Long
'max. Anzahl der Zahlen 1 bis 9 in Array einlesen
AnzahlZahl(0, 1) = Anz_0
AnzahlZahl(1, 1) = Anz_1
AnzahlZahl(2, 1) = Anz_2
AnzahlZahl(3, 1) = Anz_3
AnzahlZahl(4, 1) = Anz_4
AnzahlZahl(5, 1) = Anz_5
AnzahlZahl(6, 1) = Anz_6
AnzahlZahl(7, 1) = Anz_7
AnzahlZahl(8, 1) = Anz_8
AnzahlZahl(9, 1) = Anz_9
AnzZellen = Zeilen * Spalten
ReDim Zahlen(1 To AnzZellen, 1 To 5)
'Prüfen, ob die Summe der Anzahlen kleiner ist als die zu belegendne Zellen
For lngZahl = 0 To 9
Zufallszahl = Zufallszahl + AnzahlZahl(lngZahl, 1)
Next
If Zufallszahl lngLoopsMax Then 'Notausgang!
MsgBox "Nach " & lngLoopsMax & " Schleifen wurde noch nicht in alle " _
& "Zellen eine Zufallszahl eingetragen!"
Exit Do
End If
Loop
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub