loto kombinasyon

[gencoglu27]

Merhaba,
A sütünda 34 B c d ve E de de 34 sayı var..Bunları 5 li olarak kombinasyon yazdırmak istedim.. Aşağıdaki kod çalışıyor fakat 1 saat kadar sürüyor..Sanırım aşağıdaki kodu modife ederek daha kısa sürede sonuç almak mümkün mü ?
Teşekkür ederim.

Sub lotto34()

Dim X1, X2, X3, X4, X5, rowx
Dim i As Long
Dim m As Long, s As Long, k As Long, p As Long

i = Cells(Rows.Count, "A").End(3).Row
m = Cells(Rows.Count, "B").End(3).Row
s = Cells(Rows.Count, "C").End(3).Row
k = Cells(Rows.Count, "D").End(3).Row
p = Cells(Rows.Count, "E").End(3).Row
rowx = 1
Application.ScreenUpdating = False
Range("G:K").ClearContents

For X1 = 1 To i
For X2 = 1 To m
For X3 = 1 To s
For X4 = 1 To k
For X5 = 1 To p
If Not Cells(X1, 1) = Cells(X2, 2) Then
If Not Cells(X2, 2) = Cells(X3, 3) Then
If Not Cells(X3, 3) = Cells(X4, 4) Then
If Not Cells(X1, 1) = Cells(X3, 3) Then
If Not Cells(X1, 1) = Cells(X4, 4) Then
If Not Cells(X2, 2) = Cells(X4, 4) Then
If Not Cells(X1, 1) = Cells(X5, 5) Then
If Not Cells(X2, 2) = Cells(X5, 5) Then
If Not Cells(X3, 3) = Cells(X5, 5) Then
If Not Cells(X4, 4) = Cells(X5, 5) Then


If Cells(X1, 1) < Cells(X2, 2) And Cells(X2, 2) < Cells(X3, 3) And Cells(X3, 3) < Cells(X4, 4) And Cells(X4, 4) < Cells(X5, 5) Then
Cells(rowx, "G") = Cells(X1, 1)
Cells(rowx, "H") = Cells(X2, 2)
Cells(rowx, "I") = Cells(X3, 3)
Cells(rowx, "J") = Cells(X4, 4)
Cells(rowx, "K") = Cells(X5, 5)
rowx = rowx + 1
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If

Next
Next
Next
Next
Next


Application.ScreenUpdating = True
MsgBox "it is ok", vbInformation

End Sub

 

[usta07]

Merhaba,
A sütünda 34 B c d ve E de de 34 sayı var..Bunları 5 li olarak kombinasyon yazdırmak istedim.. Aşağıdaki kod çalışıyor fakat 1 saat kadar sürüyor..Sanırım aşağıdaki kodu modife ederek daha kısa sürede sonuç almak mümkün mü ?
Teşekkür ederim.

Merhaba,
Ek dosyayı inceleyiniz 5-25 çok kısa sürede yazıyor.

 

[gencoglu27]

Teşekkür ettim.. Ben sayı miktarını 25 ten 34 e çıkarınca ,aşağıdaki hatayı verdi..çözüm nasıl olacak..Yani programın esnek olması gerekiyor..

Range("A2").Resize(i, 1) = Application.WorksheetFunction.Transpose(dz)

Tamam çözüldü...Teşekkürler.. Kodun çalışması 1 saatten 4 dakkikaya indi..

Sub lotto34()

Dim X1 As Integer, X2 As Integer, X3 As Integer, X4 As Integer, X5 As Integer
Dim rowx As Long
Dim i As Long, m As Long, s As Long, k As Long, p As Long
Dim vData As Variant
Dim vResults As Variant

i = Cells(Rows.Count, "A").End(3).Row
m = Cells(Rows.Count, "B").End(3).Row
s = Cells(Rows.Count, "C").End(3).Row
k = Cells(Rows.Count, "D").End(3).Row
p = Cells(Rows.Count, "E").End(3).Row
rowx = 1
Range("G:K").ClearContents

'Capture activesheet data
vData = Range(Cells(1, 1), Cells(Cells(Rows.Count, "E").End(3).Row, 5))

'Set up results data
ReDim vResults(1 To 278256, 1 To 5)

For X1 = 1 To i
For X2 = 1 To m
For X3 = 1 To s
For X4 = 1 To k
For X5 = 1 To p
If Not vData(X1, 1) = vData(X2, 2) Then
If Not vData(X2, 2) = vData(X3, 3) Then
If Not vData(X3, 3) = vData(X4, 4) Then
If Not vData(X1, 1) = vData(X3, 3) Then
If Not vData(X1, 1) = vData(X4, 4) Then
If Not vData(X2, 2) = vData(X4, 4) Then
If Not vData(X1, 1) = vData(X5, 5) Then
If Not vData(X2, 2) = vData(X5, 5) Then
If Not vData(X3, 3) = vData(X5, 5) Then
If Not vData(X4, 4) = vData(X5, 5) Then
If vData(X1, 1) < vData(X2, 2) And vData(X2, 2) < vData(X3, 3) And vData(X3, 3) < vData(X4, 4) And vData(X4, 4) < vData(X5, 5) Then
'Write results data
vResults(rowx, 1) = vData(X1, 1)
vResults(rowx, 2) = vData(X2, 2)
vResults(rowx, 3) = vData(X3, 3)
vResults(rowx, 4) = vData(X4, 4)
vResults(rowx, 5) = vData(X5, 5)
rowx = rowx + 1
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next
Next
Next
Next
Next

'Display results
Range("G1").Resize(278256, 5) = vResults

End Sub