Kombinationen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: reines Interesse...

05.07.2008 20:10:52

Chris

Kombinationen

05.07.2008 21:33:32

alifa

AW: Kombinationen

06.07.2008 08:41:48

ChristianM

AW: Kombinationen

06.07.2008 13:26:00

alifa

AW: Kombinationen

06.07.2008 13:54:00

Chris

AW: Kombinationen

06.07.2008 20:38:00

ChristianM

AW: Kombinationen

07.07.2008 08:02:00

alifa

Sub TorKombi14_11() 'braucht 3226,7Sek!!! Dim a%, b%, c%, d%, e%, f%, g%, h%, i%, j%, k%, z&, t! t = Timer For a = 2 To 15 For b = a + 1 To 15 For c = b + 1 To 15 For d = c + 1 To 15 For e = d + 1 To 15 For f = e + 1 To 15 For g = f + 1 To 15 For h = g + 1 To 15 For i = h + 1 To 15 For j = i + 1 To 15 For k = j + 1 To 15 Cells(z + 1, 1) = a Cells(z + 1, 2) = b Cells(z + 1, 3) = c Cells(z + 1, 4) = d Cells(z + 1, 5) = e Cells(z + 1, 6) = f Cells(z + 1, 7) = g Cells(z + 1, 8) = h Cells(z + 1, 9) = i Cells(z + 1, 10) = j Cells(z + 1, 11) = k z = z + 1 Next Next Next Next Next Next Next Next Next Next Next MsgBox "fertig in " & Round(Timer - t, 1) & " Sek" End Sub

Servus Alifa,
probier mal das:


Sub TorKombi14_11() 'braucht 3226,7Sek!!!
Dim a%, b%, c%, d%, e%, f%, g%, h%, i%, j%, k%, z&, t!
Application.ScreenUpdating = False
t = Timer
For a = 2 To 15
For b = a + 1 To 15
For c = b + 1 To 15
For d = c + 1 To 15
For e = d + 1 To 15
For f = e + 1 To 15
For g = f + 1 To 15
For h = g + 1 To 15
For i = h + 1 To 15
For j = i + 1 To 15
For k = j + 1 To 15
Cells(z + 1, 1) = a
Cells(z + 1, 2) = b
Cells(z + 1, 3) = c
Cells(z + 1, 4) = d
Cells(z + 1, 5) = e
Cells(z + 1, 6) = f
Cells(z + 1, 7) = g
Cells(z + 1, 8) = h
Cells(z + 1, 9) = i
Cells(z + 1, 10) = j
Cells(z + 1, 11) = k
z = z + 1
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Dim ArrayX As Variant, ArrayY As Variant, ArrayZ As Variant
ArrayX = ("a,b,c,d,e,f,g,h,i,j,k,l,m,n")
ArrayY = ("2,3,4,5,6,7,8,9,10,11,12,13,14,15")
ArrayZ = ("2,3,5,7,11,13,17,19,23,29,31,37,41,43")
Dim IndexX As Variant, IndexY As Variant, IndexZ As Variant
Dim v As Long
IndexX = Split(ArrayX, ",")
IndexY = Split(ArrayY, ",")
IndexZ = Split(ArrayZ, ",")
For v = 0 To UBound(IndexY)
Cells.Replace what:=IndexY(v), Replacement:=IndexX(v), LookAt:=xlWhole
Next v
For v = 0 To UBound(IndexX)
Cells.Replace what:=IndexX(v), Replacement:=IndexZ(v), LookAt:=xlWhole
Next v
Application.ScreenUpdating = True
MsgBox "fertig in " & Round(Timer - t, 1) & " Sek"
End Sub

dauert bei mir übrigens nur 0,6 s.
Gruß
Chris

Option Explicit Sub TestKomb() Dim i As Long, u As Double, lngR As Long Dim n As Byte, k As Byte, j As Byte Dim vSrc 'Einträge: vSrc = Array(2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43) k = 11 n = UBound(vSrc) + 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) = vSrc(bPos(j) - 1) Next .Range(.Cells(lngR, 1), .Cells(lngR, k)).Value = vRes Call GetComb(n, k, bPos) Next End With Application.ScreenUpdating = True 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

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread