Makro Kombinationen
alifa
irgendwie komme ich nicht zu Rande mit diesem Problem. Das Makro macht alle Kombinationen je 6 aus den 36 Zahlen im Array a. Das sind 1947792 Zeilen. Ich brauche aber nur einige wenige. Bedingung. Die 6 sechsstellige Zahlen werden untereinender geschrieben. Die 24 Zahlen, die entstehen wenn dieses Zahlenquadrat gelesen wird, vorwärts(normal), rückwärts, rauf, runter sollen verschieden sein. Wie greift man auf die einzelnen Glieder der Kombinationen zu, bevor sie in die Zellen geschrieben werden?
Option Explicit
Sub WieGehtsWeiter()
Dim i As Long, u As Double, lngR As Long
Dim n As Byte, k As Byte, j As Byte
Dim a, t!, q, z%
t = Timer
'Einträge:
a = Array(125643, 134652, 145236, 153426, 162435, 163254, 213465, 236145, _
243516, 254163, 256431, 261534, 312564, 325416, 342615, 346521, 351624, 361452, 416325, _
426153, 431256, 435162, 452361, 465213, 516243, 521346, 523614, 534261, 541632, _
564312, 614523, 615342, 624351, 632541, 643125, 652134)
k = 6
n = UBound(a) + 1
'If k > n Then MsgBox "k > n", 16: Exit Sub
With Application
u = .Fact(n) / (.Fact(k) * .Fact(n - k))
End With
'If u > Rows.Count Then MsgBox u & " > " & Rows.Count, 16: Exit Sub
ReDim vRes(k - 1)
ReDim bPos(k - 1) As Byte
For i = 1 To k
bPos(i - 1) = i
Next
Application.ScreenUpdating = False
With ActiveSheet
.Cells.Delete
For i = 1 To u
lngR = lngR + 1
For j = 0 To UBound(bPos)
vRes(j) = a(bPos(j) - 1)
Next
.Range(.Cells(lngR, 1), .Cells(lngR, k)).Value = vRes
Call GetComb(n, k, bPos)
Next
End With
Application.ScreenUpdating = True
MsgBox "fertig in " & Round(Timer - t, 2) & " Sek "
End Sub
Sub GetComb(ByVal n As Byte, ByVal k As Byte, bPos() As Byte)
Dim i As Byte, j As Byte
i = k - 1
Do While bPos(i) >= n - k + i + 1
If i = 0 Then Exit Do
i = i - 1
Loop
bPos(i) = bPos(i) + 1
For j = i To k - 1
bPos(j) = bPos(i) + j - i
Next
End Sub