• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kombinasyon makrosunda düzeltme

M

Muharrem41

Katılım
15 Eylül 2016
Mesajlar
39
Excel Vers. ve Dili
türkçe 2007
Kod: 
Sub Listele()
Dim X As Byte, z As Long
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte, f As Byte, g As Byte

X = 49

For a = 1 To X
For b = a + 1 To X
For c = b + 1 To X
For d = c + 1 To X
For e = d + 1 To X
For f = e + 1 To X
z = z + 1
Cells(z, 1) = a
Cells(z, 2) = b
Cells(z, 3) = c
Cells(z, 4) = d
Cells(z, 5) = e
Cells(z, 6) = f
Next f
Next e
Next d
Next c
Next b
Next a

End Sub

Merhaba arkadaşlar elimde şöyle bir macro var macro çalışıyor fakat sayıları tam olarak üretmiyor benim istedigim excel satırı 1048576 da hata veriyor satır bittikten sonra kalan sayıları ghıijk sutunlarına yazdıra bilirmiyim lütfen yardım
 
Yazdırdığınız sayfanın adı nedir?
Ayrıca bu koddaki döngü ne zaman bitiyor? :)

Sonsuza mı gitmeye çalışıyor bu kod? :)
 
Son düzenleme:
Aşağıdaki gibi kullanabilirsiniz.

Kod: 
Sub Listele()
    Dim x As Byte, y As Long, z As Long
    Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte, f As Byte, g As Byte
    
    Cells.Clear
    x = 49
    z = 1
    
    For a = 1 To x
        For b = a + 1 To x
            For c = b + 1 To x
                For d = c + 1 To x
                    For e = d + 1 To x
                        For f = e + 1 To x
                            y = y + 1
                            If y > 1048576 Then
                                y = 1
                                z = z + 7
                            End If
                            Cells(y, z) = a
                            Cells(y, z + 1) = b
                            Cells(y, z + 2) = c
                            Cells(y, z + 3) = d
                            Cells(y, z + 4) = e
                            Cells(y, z + 5) = f
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Aşağıdaki gibi kullanabilirsiniz.

Kod: 
Sub Listele()
    Dim x As Byte, y As Long, z As Long
    Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte, f As Byte, g As Byte
    
    Cells.Clear
    x = 49
    z = 1
    
    For a = 1 To x
        For b = a + 1 To x
            For c = b + 1 To x
                For d = c + 1 To x
                    For e = d + 1 To x
                        For f = e + 1 To x
                            y = y + 1
                            If y > 1048576 Then
                                y = 1
                                z = z + 7
                            End If
                            Cells(y, z) = a
                            Cells(y, z + 1) = b
                            Cells(y, z + 2) = c
                            Cells(y, z + 3) = d
                            Cells(y, z + 4) = e
                            Cells(y, z + 5) = f
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Korhan Hocam,

Döngünün tamamlanması ne kadar sürdü?
Ben de sürekli excel sayfası dondu, işlemin sonunu göremedim yani.
 
14 sütun oluşuyor.
Sayısal Loto'yu tutturma ihtimali 1/13 983 816. :)
 
Muharrem41' Alıntı:
hatamı var
Genişletmek için tıkla ...
Merhaba
Aşağıdaki gibi deneyiniz, hem hızlı olması açısından faydası olacaktır.
Kod: 
[SIZE="2"]Sub Listele()
Dim kom()
Dim a, b, c, d, e, f, i, x, n, j As Integer
Cells.Clear
ReDim kom(1 To 6, 1 To 65536)
i = 0: n = 1: j = 1: x = 0
For a = 1 To [COLOR="Red"]44[/COLOR]
For b = a + 1 To [COLOR="Red"]45[/COLOR]
For c = b + 1 To [COLOR="Red"]46[/COLOR]
For d = c + 1 To [COLOR="Red"]47[/COLOR]
For e = d + 1 To [COLOR="Red"]48[/COLOR]
For f = e + 1 To 49
i = i + 1
kom(1, i) = a
kom(2, i) = b
kom(3, i) = c
kom(4, i) = d
kom(5, i) = e
kom(6, i) = f
If i = 65536 Then
x = x + 1
Cells(n, j).Resize(i, 6) = Application.Transpose(kom)
If x = Rows.Count / 65536 Then
x = 0: n = 1: i = 0
j = j + 6
End If
Cells(n + i, j).Select
n = n + i
 Erase kom: i = 0
ReDim kom(1 To 6, 1 To 65536)
 End If
Next: Next: Next: Next: Next: Next
[COLOR="Blue"]If i > 0 Then Cells(n, j).Resize(i, 6) = Application.Transpose(kom)[/COLOR]
End Sub
 [/SIZE]
 
Son düzenleme:
Hata yok. Makronun bitmesini beklemeniz gerekiyor. İç içe döngü olduğu için uzun sürecektir.

Alternatif olarak verilen kodu deneyiniz. Daha hızlı sonuç üretecektir.
 
plint' Alıntı:
merhaba
aşağıdaki gibi deneyiniz, hem hızlı olması açısından faydası olacaktır.
Kod: 
[sıze="2"]sub listele()
dim kom()
dim a, b, c, d, e, f, i, x, n, j as ınteger
cells.clear
redim kom(1 to 6, 1 to 65536)
i = 0: N = 1: J = 1: X = 0
for a = 1 to [color="red"]44[/color]
for b = a + 1 to [color="red"]45[/color]
for c = b + 1 to [color="red"]46[/color]
for d = c + 1 to [color="red"]47[/color]
for e = d + 1 to [color="red"]48[/color]
for f = e + 1 to 49
i = i + 1
kom(1, i) = a
kom(2, i) = b
kom(3, i) = c
kom(4, i) = d
kom(5, i) = e
kom(6, i) = f
ıf i = 65536 then
x = x + 1
cells(n, j).resize(i, 6) = application.transpose(kom)
ıf x = rows.count / 65536 then
x = 0: N = 1: I = 0
j = j + 6
end ıf
cells(n + i, j).select
n = n + i
 erase kom: I = 0
redim kom(1 to 6, 1 to 65536)
 end ıf
next: Next: Next: Next: Next: Next
[color="blue"]ıf i > 0 then cells(n, j).resize(i, 6) = application.transpose(kom)[/color]
end sub
 [/sıze]
Genişletmek için tıkla ...

hocam eline koluna emeğine sağlık teşekkür ederim
 
10'lu sütundan kastınız nedir?
 
123456 lı olarak değilde
konbinasyon u
12345678910 olarak yapmak istiyorum 30/10
 
Hocam iyi akşamlar

Kod: 
Sub Listele()
    Dim x As Byte, y As Long, z As Long
    Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte, f As Byte, g As Byte
    
    Cells.Clear
    x = 49
    z = 1
    
    For a = 1 To x
        For b = a + 1 To x
            For c = b + 1 To x
                For d = c + 1 To x
                    For e = d + 1 To x
                        For f = e + 1 To x
                            y = y + 1
                            If y > 1048576 Then
                                y = 1
                                z = z + 7
                            End If
                            Cells(y, z) = a
                            Cells(y, z + 1) = b
                            Cells(y, z + 2) = c
                            Cells(y, z + 3) = d
                            Cells(y, z + 4) = e
                            Cells(y, z + 5) = f
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

KORHAN HOCAM BUNU SİZ YAPTINIZ BEN BUNU 6 LI SÜTÜNDA DEĞİLDE 10 LU SÜTUNDA YAPMAK İSTİYORUM
 
1-49 arası sayıların 10'lu kombinasyonlarını istiyorsunuz? Doğru mudur?
 
Korhan hocam böyle bir şansım varmı matık en olması lazım diye düşünüyorum
 
macro hakkında

PLİNT' Alıntı:
Merhaba
Aşağıdaki gibi deneyiniz, hem hızlı olması açısından faydası olacaktır.
Kod: 
[SIZE="2"]Sub Listele()
Dim kom()
Dim a, b, c, d, e, f, i, x, n, j As Integer
Cells.Clear
ReDim kom(1 To 6, 1 To 65536)
i = 0: n = 1: j = 1: x = 0
For a = 1 To [COLOR="Red"]44[/COLOR]
For b = a + 1 To [COLOR="Red"]45[/COLOR]
For c = b + 1 To [COLOR="Red"]46[/COLOR]
For d = c + 1 To [COLOR="Red"]47[/COLOR]
For e = d + 1 To [COLOR="Red"]48[/COLOR]
For f = e + 1 To 49
i = i + 1
kom(1, i) = a
kom(2, i) = b
kom(3, i) = c
kom(4, i) = d
kom(5, i) = e
kom(6, i) = f
If i = 65536 Then
x = x + 1
Cells(n, j).Resize(i, 6) = Application.Transpose(kom)
If x = Rows.Count / 65536 Then
x = 0: n = 1: i = 0
j = j + 6
End If
Cells(n + i, j).Select
n = n + i
 Erase kom: i = 0
ReDim kom(1 To 6, 1 To 65536)
 End If
Next: Next: Next: Next: Next: Next
[COLOR="Blue"]If i > 0 Then Cells(n, j).Resize(i, 6) = Application.Transpose(kom)[/COLOR]
End Sub
 [/SIZE]
Genişletmek için tıkla ...
hocam bunu 123456 lı olarak değilde
kombinasyon u
12345678910 olarak yapmak istiyorum yani 1/30 kombinasyon unu 10 lu istiyorum mümkünmü?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst