Zufallszahlen generieren

[Max]

Hallo Atilla,

verstehe ich nicht...
Hier mal die Ergenisse von drei Durchläufen aus den ersten 25 Zeilen.

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C
1	27, 14, 32, 11	4, 20, 31, 30	4, 5, 7, 6
2	31, 3, 30, 26	24, 5, 9, 27	18, 15, 0, 19
3	18, 32, 34, 16	17, 10, 3, 28	9, 10, 5, 35
4	5, 3, 8, 2	13, 8, 25, 30	18, 16, 13, 25
5	17, 31, 30, 3	16, 21, 35, 0	11, 7, 5, 19
6	29, 10, 4, 28	26, 4, 17, 33	36, 22, 23, 27
7	5, 25, 16, 11	11, 5, 18, 19	12, 11, 3, 7
8	36, 35, 19, 1	16, 27, 22, 35	6, 34, 4, 27
9	7, 2, 12, 20	11, 23, 36, 19	0, 16, 15, 11
10	36, 31, 19, 2	29, 17, 11, 3	3, 30, 0, 13
11	7, 26, 30, 35	25, 14, 16, 23	20, 23, 18, 9
12	1, 35, 9, 36	30, 17, 18, 3	12, 19, 3, 15
13	15, 23, 3, 32	15, 21, 0, 33	24, 3, 36, 4
14	3, 4, 11, 20	28, 24, 33, 1	9, 21, 35, 14
15	4, 31, 15, 35	2, 35, 34, 25	13, 35, 27, 0
16	6, 33, 3, 32	23, 3, 7, 33	22, 23, 19, 17
17	21, 24, 6, 25	25, 7, 28, 17	1, 7, 14, 22
18	33, 3, 35, 23	25, 29, 0, 16	8, 28, 16, 27
19	17, 2, 3, 13	0, 34, 17, 10	3, 20, 25, 22
20	4, 34, 10, 18	28, 25, 27, 5	8, 30, 0, 7
21	24, 18, 14, 13	24, 10, 35, 18	20, 5, 29, 27
22	23, 30, 29, 4	27, 20, 16, 28	9, 1, 31, 3
23	8, 24, 4, 29	17, 33, 26, 11	34, 30, 8, 26
24	17, 27, 33, 19	36, 8, 22, 5	15, 1, 27, 26
25	36, 32, 9, 25	11, 1, 9, 8	24, 22, 15, 9

Ich habe jedes Mal andere Werte

Eine kleine Modifikation hatte ich noch im unteren Teil. Das hat aber auch keine Auswirkung auf die Werte.

Code:

'Die ersten vier Werte aus Array werden ausgelesen und an Zufall übergeben
   For i = 0 To 0 + Anzahl - 1
       Zufall = Zufall & ", " & Varray(i)
       Tabelle1.Range("C" & z) = Mid(Trim(Zufall), 2)
   Next i

Gruß
Max

Edit:

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C
1	23, 13, 3, 19	1	1000
2	22, 16, 30, 29	1
3	1, 19, 26, 6	1
4	27, 4, 10, 29	1
5	21, 27, 6, 16	1
6	7, 0, 24, 11	1
7	9, 4, 20, 26	1
8	9, 18, 16, 33	1
9	2, 26, 30, 12	1
10	25, 12, 11, 18	1
11	3, 31, 18, 6	1
12	35, 34, 23, 32	1
13	24, 33, 27, 5	1
14	3, 29, 11, 23	1
15	13, 25, 29, 32	1
16	2, 32, 18, 9	1
17	11, 4, 29, 34	1
18	9, 11, 7, 26	1
19	22, 25, 5, 26	1
20	21, 3, 12, 20	1
21	34, 28, 16, 2	1
22	15, 2, 0, 1	1
23	23, 14, 2, 24	1
24	15, 12, 0, 20	1
25	21, 25, 14, 18	1

Zelle	Formel
B1	=ZÄHLENWENN($A$1:$A$1000;$A1)
C1	=ZÄHLENWENN($B$1:$B$1000;1)
B2	=ZÄHLENWENN($A$1:$A$1000;$A2)
B3	=ZÄHLENWENN($A$1:$A$1000;$A3)
B4	=ZÄHLENWENN($A$1:$A$1000;$A4)
B5	=ZÄHLENWENN($A$1:$A$1000;$A5)
B6	=ZÄHLENWENN($A$1:$A$1000;$A6)
B7	=ZÄHLENWENN($A$1:$A$1000;$A7)
B8	=ZÄHLENWENN($A$1:$A$1000;$A8)
B9	=ZÄHLENWENN($A$1:$A$1000;$A9)
B10	=ZÄHLENWENN($A$1:$A$1000;$A10)
B11	=ZÄHLENWENN($A$1:$A$1000;$A11)
B12	=ZÄHLENWENN($A$1:$A$1000;$A12)
B13	=ZÄHLENWENN($A$1:$A$1000;$A13)
B14	=ZÄHLENWENN($A$1:$A$1000;$A14)
B15	=ZÄHLENWENN($A$1:$A$1000;$A15)
B16	=ZÄHLENWENN($A$1:$A$1000;$A16)
B17	=ZÄHLENWENN($A$1:$A$1000;$A17)
B18	=ZÄHLENWENN($A$1:$A$1000;$A18)
B19	=ZÄHLENWENN($A$1:$A$1000;$A19)
B20	=ZÄHLENWENN($A$1:$A$1000;$A20)
B21	=ZÄHLENWENN($A$1:$A$1000;$A21)
B22	=ZÄHLENWENN($A$1:$A$1000;$A22)
B23	=ZÄHLENWENN($A$1:$A$1000;$A23)
B24	=ZÄHLENWENN($A$1:$A$1000;$A24)
B25	=ZÄHLENWENN($A$1:$A$1000;$A25)

[atilla]

Hallo zusammen,

hab meine Variante etwas überarbeitet, ich denke jetzt müsste es funktionieren:

Code:

Option Explicit

Sub tausender()
 Dim j As Long, i As Long, k
 Dim lozahl As Long
 Dim varKey
 Dim varFeld1
 Dim arr1()
 Dim objDic As Object
 Dim arrZahlen, arr
 Set objDic = CreateObject("Scripting.Dictionary")
 Do
   arrZahlen = ""
   Do
     Randomize
     lozahl = Application.WorksheetFunction.RandBetween(0, 36) 'sechs unterschiedliche Zufallszahlen generieren
     If InStr(arrZahlen, lozahl) = 0 Then
       arrZahlen = lozahl & "##" & arrZahlen     'Zufallszahlen in ein mit Leerzeichen getrennt in ein Array schreiben
       i = i + 1
     End If
   Loop While i < 4

   If Not objDic.exists(arrZahlen) Then
       objDic(arrZahlen) = arrZahlen
       j = j + 1
   End If
   i = 0
 Loop While j < 1000
 arr = objDic.keys
 j = 0
 ReDim arr1(objDic.Count - 1, 3)
 For i = 0 To objDic.Count - 1
     For k = 0 To UBound(Split(arr(i), "##")) - 1
         arr1(j, k) = Split(arr(i), "##")(k)
     Next k
      j = j + 1
 Next i
 
 Range("A1:D1000") = arr1
 
End Sub

[BoskoBiati]

Hallo Atilla,

das war der Punkt, bei dem ich hängengeblieben bin, alle Zahlen in ein Array zu schreiben.
Das Umwandeln in Zahlen war notwendig, weil die Ergebnisse immer als Texte in die zellen geschrieben wurden.
Ich habe das Schreiben in das Array jetzt noch in die erste Schleife gepackt. Jetzt habe ich drei Versionen getestet, die Unterschiede sind marginal:

Arbeitsblatt mit dem Namen 'Tabelle1'
	E	F
1	Klick1	0,5334375
2	Klick2	0,50835938
3	Klick3	0,4903125

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Code:

Sub Klick1()
 Dim loB As Long
 Dim lozahl As Long
 Dim arrZahlen, arrZahlen2(3), arrZahlen3(999)
 Dim loa As Long
 Dim bolTreffer As Boolean
 
 
    loa = 0
Do
    bolTreffer = False
    arrZahlen = ""
    Do
      Randomize
      lozahl = Application.WorksheetFunction.RandBetween(0, 36) 'vier unterschiedliche Zufallszahlen generieren
      If InStr(arrZahlen, lozahl) = 0 Then
        arrZahlen = lozahl & " " & arrZahlen     'Zufallszahlen in ein mit Leerzeichen getrennt in ein Array schreiben
        arrZahlen2(loB) = lozahl
        loB = loB + 1
      End If
    Loop While loB < 4
    
    For loB = 0 To 3
       arrZahlen3(loa) = arrZahlen3(loa) & WorksheetFunction.Small(arrZahlen2, loB + 1) & " " 'Mit kkleinste sortiert den Arrayinhalt wieder zurückschreiben
    Next
    If loa > 0 Then
        For loB = 0 To loa - 1
            If arrZahlen3(loB) = arrZahlen3(loa) Then bolTreffer = True
        Next
    End If
        If bolTreffer = False Then loa = loa + 1

        loB = 0
    
 Loop While loa < 1000
 For loa = 0 To 999
    Range(Cells(loa + 1, 1), Cells(loa + 1, 4)) = Split(arrZahlen3(loa), " ")
 Next
 With Range("A1:D1000")
 .NumberFormat = "General"
 .Value = .Value
 End With

End Sub
Sub Klick2()
 Dim loa As Long
Dim loB As Long
Dim lozahl As Long
Dim k As Long
Dim arrZahlen, arrZahlen2(3), arrZahlen3(999)
Dim arr(999, 3)
Dim bolTreffer As Boolean

   loa = 0
Do
   bolTreffer = False
   arrZahlen = ""
   Do
     Randomize
     lozahl = Application.WorksheetFunction.RandBetween(0, 36) 'vier unterschiedliche Zufallszahlen generieren
     If InStr(arrZahlen, lozahl) = 0 Then
       arrZahlen = lozahl & " " & arrZahlen     'Zufallszahlen in ein mit Leerzeichen getrennt in ein Array schreiben
       arrZahlen2(loB) = lozahl
       loB = loB + 1
     End If
   Loop While loB < 4
   
   For loB = 0 To 3
      arrZahlen3(loa) = arrZahlen3(loa) & WorksheetFunction.Small(arrZahlen2, loB + 1) & " " 'Mit kkleinste sortiert den Arrayinhalt wieder zurückschreiben
   Next
   If loa > 0 Then
       For loB = 0 To loa - 1
           If arrZahlen3(loB) = arrZahlen3(loa) Then bolTreffer = True
       Next
   End If
       If bolTreffer = False Then loa = loa + 1

       loB = 0
   
Loop While loa < 1000

For loa = 0 To 999
 k = 0
 For loB = 0 To 3
   arr(loa, k) = Split(arrZahlen3(loa))(loB)
   k = k + 1
 Next loB
Next

With Range("A1:D1000")
.Value = arr
.NumberFormat = "General"
.Value = .Value
End With


End Sub
Sub Klick3()
 Dim loa As Long
Dim loB As Long
Dim lozahl As Long
Dim k As Long
Dim arrZahlen, arrZahlen2(3), arrZahlen3(999)
Dim arr(999, 3)
Dim bolTreffer As Boolean


   loa = 0
Do
   bolTreffer = False
   arrZahlen = ""
   Do
     Randomize
     lozahl = Application.WorksheetFunction.RandBetween(0, 36) 'vier unterschiedliche Zufallszahlen generieren
     If InStr(arrZahlen, lozahl) = 0 Then
       arrZahlen = lozahl & " " & arrZahlen     'Zufallszahlen in ein mit Leerzeichen getrennt in ein Array schreiben
       arrZahlen2(loB) = lozahl
       loB = loB + 1
     End If
   Loop While loB < 4
   
   For loB = 0 To 3
      arrZahlen3(loa) = arrZahlen3(loa) & WorksheetFunction.Small(arrZahlen2, loB + 1) & " " 'Mit kkleinste sortiert den Arrayinhalt wieder zurückschreiben
   Next
   If loa > 0 Then
       For loB = 0 To loa - 1
           If arrZahlen3(loB) = arrZahlen3(loa) Then bolTreffer = True
       Next
   End If
       If bolTreffer = False Then loa = loa + 1
   
 For loB = 0 To 3
   arr(loa - 1, loB) = Split(arrZahlen3(loa - 1))(loB)
 Next loB
 loB = 0
Loop While loa < 1000

With Range("A1:D1000")
.Value = arr
.NumberFormat = "General"
.Value = .Value
End With


End Sub

[atilla]

Hallo Max,

alles Ok, war meine Schludrigkeit. :@

Ich wollte in eine andere Tabelle schreiben lassen als Tablle1. Da habe ich dann nicht überall Tabell1 ersetzt.
Sorry.

Ist auch eine raffinierte Idee von Dir. Auch für dich gilt, dass Du Zeit beim Schreiben in die Tabelle verlierst.
Könntest am Ende statt in die Tabelle zu schreiben genauso in ein Array schreiben und dann diesen Array Inhalt in einem in die Tabelle schreiben.
Du hast die Zahlen in einer Zelle, wobei Edgar und ich sie in 4 Spalten verteilen. Aber je nach dem, was der TE wünscht kann das dann auch bei Dir schnell noch eingearbeitet werden.

[Max]

Hi Atilla,

echt jetzt?

1 Sekunde für 1000 oder auch 2000 Kombinationen.
Bei 4000 sind es dann 2 Sekunden.

Das ist aber Jammern auf ganz hohem Niveau, oder?

Gruß
Max

[atilla]

Hallo Max,

ich jammer doch nicht.

Du arbeitest doch bis kurz vor Schluss mit Arrays, warum an der entscheidenden Stelle nicht.
Entscheidend in dem Sinne, dass das Programm zum Schreiben in die Tabelle die meiste Zeit benötigt.
Gefühlt 99% der gesamten Zeit gehen bei Dir zum Schreiben drauf.
Aber wenigstens die Bildschirmaktualisierung könnte noch abgeschaltet werden. Das macht dann auch einiges aus.

Also warum nicht konsequent bis zum Ende mit Arrays weitermachen?

[atilla]

Hallo Edgar,

hast Du bei Dir geprüft, ob Du Doppelte hast?
Ich habe jetzt die Klick2 und Klick3 getestet und erhalte jedes mal um die 20 Doppelte.

So habe ich getestet:

Arbeitsblatt mit dem Namen 'Tabelle2'
	A	B	C	D	E	F	G	H
1	11	15	33	34	11153334	1	980	1000
2	0	14	33	35	0143335	1

Zelle	Formel
E1	=A1&B1&C1&D1
F1	=ZÄHLENWENN($E$1:$E$2001;E1)
G1	=ZÄHLENWENN(F1:F1000;1)
H1	=ANZAHL(F1:F1000)

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

und noch einmal so getestet:

Arbeitsblatt mit dem Namen 'Tabelle2'
	A	B	C	D	E	F	G	H
1	1	13	29	36	1#13#29#36	1	972	1000

Zelle	Formel
E1	=A1&"#"&B1&"#"&C1&"#"&D1
F1	=ZÄHLENWENN($E$1:$E$2001;E1)
G1	=ZÄHLENWENN(F1:F2001;"=1")
H1	=ANZAHL(F1:F2000)

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

[BoskoBiati]

Hallo Atilla,

ich bin noch amTesten.

[atilla]

Hallo zusammen,


endlich habe ich verstanden, warum Edgar die Zahlen sortiert.

Deswegen hier meine neueste Version:

Code:

Option Explicit

Sub zufallszahlen()
 Dim j As Long, i As Long
 Dim lozahl As Long
 Dim lngAnzahl As Long
 Dim arr()
 Dim arrZahlen, arrZahlen2
 Dim objDic1 As Object, objDic2 As Object
 
 Set objDic1 = CreateObject("Scripting.Dictionary")
 Set objDic2 = CreateObject("Scripting.Dictionary")
 
 lngAnzahl = Application.InputBox("Bitte Karten-Anzahl eingeben", "Zahleneingabe", 1000, Type:=1)
 If lngAnzahl > 0 and lngAnzahl < 66045 Then
   Do
     arrZahlen2 = ""
     Do
       Randomize
       lozahl = Application.WorksheetFunction.RandBetween(0, 36) '4 unterschiedliche Zufallszahlen generieren
       If Not objDic1.exists(lozahl) Then
           objDic1(lozahl) = lozahl
       End If
     Loop Until objDic1.Count = 4
     
     arrZahlen = objDic1.keys   'Zufallszahlen in ein Array einlesen
     'sortieren des Arrayinhalts mittels der Tabellenfunktion Kkleinste und hintereinander mit # getrennt in eine Feldvariable schreiben
     For i = 4 To 1 Step -1
       arrZahlen2 = WorksheetFunction.Small(arrZahlen, i) & "##" & arrZahlen2
     Next i
     
     If Not objDic2.exists(arrZahlen2) Then 'Sammeln der Kombinationen bei gleichzeitiger Prüfung ob schon vorhanden
         objDic2(arrZahlen2) = arrZahlen2
     End If
     objDic1.RemoveAll
   Loop Until objDic2.Count = lngAnzahl
 End If
 
 arrZahlen = ""
 arrZahlen = objDic2.keys
 
 j = 0
 ReDim arr(objDic2.Count - 1, 3) 'Alle gesamelten Kombinationen bei ## trennen und in ein Array schreiben
 For i = 0 To objDic2.Count - 1
     For j = 0 To UBound(Split(arrZahlen(i), "##")) - 1
         arr(i, j) = Split(arrZahlen(i), "##")(j)
     Next j
 Next i
 
 Application.Calculation = xlCalculationManual     'Berechnung abschalten
 Columns("A:D").ClearContents                      'Spalten A bis D leeren
 Range("A1:D" & lngAnzahl) = arr                   'Den Arrayinhalt in die Tabelle schreiben
 Application.Calculation = xlCalculationAutomatic  'Berechnung einschalten
End Sub

Ich habe für den Nutzer noch eine Inputbox eingebaut.

[BoskoBiati]

Hallo Atilla,

ich weiß jetzt auch, warum es zu Dopplern kam:
in der Schleife wurde ein doppeltes Vorkommen festgestellt, darauf wurde ein neues Array erstellt, ohne dass das alte geleert wurde. Das neue hatte dann 8Zahlen und war darum einmalig. Beim Übertrag in die Zellen wurden aber nur die ersten vier Zahlen eingetragen, also die doppelten.

Hier das verbesserte Makro:

Code:

Sub Klick2()
Dim loA As Long
Dim loB As Long
Dim lozahl As Long
Dim k As Long
Dim arrZahlen, arrZahlen2(3), arrZahlen3(999)
Dim arr(999, 3)
Dim bolTreffer As Boolean

  loA = 0
Do
  bolTreffer = False
  arrZahlen = ""
  Do
    Randomize
    lozahl = Application.WorksheetFunction.RandBetween(0, 36) 'vier unterschiedliche Zufallszahlen generieren
    If InStr(arrZahlen, lozahl) = 0 Then
      arrZahlen = lozahl & " " & arrZahlen     'Zufallszahlen in ein mit Leerzeichen getrennt in ein Array schreiben
      arrZahlen2(loB) = lozahl
      loB = loB + 1
    End If
  Loop While loB < 4
 
  For loB = 0 To 3
     arrZahlen3(loA) = arrZahlen3(loA) & WorksheetFunction.Small(arrZahlen2, loB + 1) & " " 'Mit kkleinste sortiert den Arrayinhalt wieder zurückschreiben
  Next
  If loA > 0 Then
      For loB = 0 To loA - 1
           If arrZahlen3(loA) = arrZahlen3(loB) Then
               bolTreffer = True
               arrZahlen3(loA) = ""
               Exit For
           End If
      Next
  End If
      If bolTreffer = False Then loA = loA + 1

      loB = 0
 
Loop While loA < 1000

For loA = 0 To 999
k = 0
For loB = 0 To 3
  arr(loA, k) = Split(arrZahlen3(loA))(loB)
  k = k + 1
Next loB
Next

With Range("A1:D1000")
.Value = arr
.NumberFormat = "General"
.Value = .Value
End With


End Sub
Sub Klick3()
Dim loA As Long
Dim loB As Long
Dim lozahl As Long
Dim k As Long
Dim arrZahlen, arrZahlen2(3), arrZahlen3(999)
Dim arr(999, 3)
Dim bolTreffer As Boolean


  loA = 0
Do
  bolTreffer = False
  arrZahlen = ""
  Do
    Randomize
    lozahl = Application.WorksheetFunction.RandBetween(0, 36) 'vier unterschiedliche Zufallszahlen generieren
    If InStr(arrZahlen, lozahl) = 0 Then
      arrZahlen = lozahl & " " & arrZahlen     'Zufallszahlen in ein mit Leerzeichen getrennt in ein Array schreiben
      arrZahlen2(loB) = lozahl
      loB = loB + 1
    End If
  Loop While loB < 4
 
  For loB = 0 To 3
     arrZahlen3(loA) = arrZahlen3(loA) & WorksheetFunction.Small(arrZahlen2, loB + 1) & " " 'Mit kkleinste sortiert den Arrayinhalt wieder zurückschreiben
  Next
  If loA > 0 Then
      For loB = 0 To loA - 1
           If arrZahlen3(loA) = arrZahlen3(loB) Then
               bolTreffer = True
               arrZahlen3(loA) = ""
               Exit For
           End If
      Next
  End If
      If bolTreffer = False Then loA = loA + 1
 
For loB = 0 To 3
  arr(loA - 1, loB) = Split(arrZahlen3(loA - 1))(loB)
Next loB
loB = 0
Loop While loA < 1000

With Range("A1:D1000")
.Value = arr
.NumberFormat = "General"
.Value = .Value
End With


End Sub

Ich werde mir jetzt dein neues Werk ansehen, dann gehts ins Bett.