Registriert seit: 01.11.2014
Version(en): 2007, 2010
25.02.2015, 21:19
(Dieser Beitrag wurde zuletzt bearbeitet: 25.02.2015, 21:34 von 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) |
Registriert seit: 14.04.2014
Version(en): 2003, 2007
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
Gruß Atilla
Registriert seit: 13.04.2014
Version(en): 365, 2019
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
Gruß
Edgar
Meine Antworten sind freiwillig und ohne Gewähr!
Über Rückmeldungen würde ich mich freuen.
Registriert seit: 14.04.2014
Version(en): 2003, 2007
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.
Gruß Atilla
Registriert seit: 01.11.2014
Version(en): 2007, 2010
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
Registriert seit: 14.04.2014
Version(en): 2003, 2007
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?
Gruß Atilla
Registriert seit: 14.04.2014
Version(en): 2003, 2007
25.02.2015, 21:54
(Dieser Beitrag wurde zuletzt bearbeitet: 25.02.2015, 22:02 von 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 |
Gruß Atilla
Registriert seit: 13.04.2014
Version(en): 365, 2019
Hallo Atilla,
ich bin noch amTesten.
Gruß
Edgar
Meine Antworten sind freiwillig und ohne Gewähr!
Über Rückmeldungen würde ich mich freuen.
Registriert seit: 14.04.2014
Version(en): 2003, 2007
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.
Gruß Atilla
Registriert seit: 13.04.2014
Version(en): 365, 2019
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.
Gruß
Edgar
Meine Antworten sind freiwillig und ohne Gewähr!
Über Rückmeldungen würde ich mich freuen.
|
