DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Merhaba,Arkadaşlar bi fikriniz yokmu
Sub test()
z = 6: x = 4
For i = 1 To 3
x = x + 1
For y = z To 12
s = s + 1
Cells(s, 5) = Cells(1, 1) & "-" & Cells(1, 1) & "/" & Cells(1, 1) & "-" & Cells(2, 1) & "/" & _
Cells(1, 1) & "-" & Cells(3, 1) & "/" & Cells(1, 1) & "-" & Cells(4, 1) & "/" & _
Cells(1, 1) & "-" & Cells(x, 1) & "/" & Cells(1, 1) & "-" & Cells(y, 1)
Next
z = z + 1
Next
End Sub
Sub test1()
z = 6: x = 4
For i = 1 To 3
x = x + 1
For y = z To 12
s = s + 1
Cells(s, 6) = Cells(1, 1) - Cells(1, 1) - Cells(1, 1) - Cells(2, 1) - _
Cells(1, 1) - Cells(3, 1) - Cells(1, 1) - Cells(4, 1) - _
Cells(1, 1) - Cells(x, 1) - Cells(1, 1) - Cells(y, 1)
Next
z = z + 1
Next
End Sub
Merhaba, sorunuz net anlayamadım.
Özel mesajınıza istinaden cevaplıyorum.
Dosyanızdaki tablo ile sınırlı olamak şartıyla. Dosyanıza uygun olarak.Kod:Sub test() z = 6: x = 4 For i = 1 To 3 x = x + 1 For y = z To 12 s = s + 1 Cells(s, 5) = Cells(1, 1) & "-" & Cells(1, 1) & "/" & Cells(1, 1) & "-" & Cells(2, 1) & "/" & _ Cells(1, 1) & "-" & Cells(3, 1) & "/" & Cells(1, 1) & "-" & Cells(4, 1) & "/" & _ Cells(1, 1) & "-" & Cells(x, 1) & "/" & Cells(1, 1) & "-" & Cells(y, 1) Next z = z + 1 Next End SubKod:Sub test1() z = 6: x = 4 For i = 1 To 3 x = x + 1 For y = z To 12 s = s + 1 Cells(s, 6) = Cells(1, 1) - Cells(1, 1) - Cells(1, 1) - Cells(2, 1) - _ Cells(1, 1) - Cells(3, 1) - Cells(1, 1) - Cells(4, 1) - _ Cells(1, 1) - Cells(x, 1) - Cells(1, 1) - Cells(y, 1) Next z = z + 1 Next End Sub
Sub Dene2()
[d1:e65536].ClearContents
Sat = 1
Sut = 4
For a = 1 To 7
For b = 2 To 8
For c = 3 To 9
For d = 4 To 10
For e = 5 To 11
For f = 6 To 12
Cells(Sat, Sut) = Cells(a, "a") & Cells(a, "a") _
& "-" & Cells(a, "a") & Cells(b, "a") & "-" & Cells(a, "a") _
& Cells(c, "a") & "-" & Cells(a, "a") & Cells(d, "a") _
& "-" & Cells(a, "a") & Cells(e, "a") & "-" & Cells(a, "a") & Cells(f, "a")
Sat = Sat + 1
If Sat = 65536 Then
Sut = 5
Sat = 1
End If
Next
Next
Next
Next
Next
Next
End Sub
Selamlar,
Aşağıdaki eki dener misiniz? İstediğiniz sonuçları veriyor. Ancak fazlasını da veriyor. Yaklaşık 100.000 civarında sonuç çıkıyor.
Sub Dene3()
[d1:ı65536].ClearContents
Sat = 1: Sut = 4
x = 1
For i = 1 To 6
s1 = 1: s2 = 2: s3 = 3: s4 = 4: s5 = 5: s6 = 6
Tekrar:
For a = s1 To s1: For b = s2 To s2: For c = s3 To s3: For d = s4 To s4: For e = s5 To s5: For f = s6 To 12
Cells(Sat, Sut) = Cells(x, "a") & "-" & Cells(a, "a") _
& "/" & Cells(x, "a") & "-" & Cells(b, "a") & "/" & Cells(x, "a") _
& "-" & Cells(c, "a") & "/" & Cells(x, "a") & "-" & Cells(d, "a") _
& "/" & Cells(x, "a") & "-" & Cells(e, "a") & "/" & Cells(x, "a") & "-" & Cells(f, "a")
Sat = Sat + 1
Next: Next: Next: Next: Next: Next
s5 = s5 + 1: s6 = s6 + 1: If s6 = 7 Then GoTo Tekrar
s4 = s4 + 2: If s6 = 8 Then GoTo Tekrar
s4 = s4 - 1: s3 = s3 + 3: If s6 = 9 Then GoTo Tekrar
s3 = s3 - 2: s2 = s2 + 4: If s6 = 10 Then GoTo Tekrar
Sut = Sut + 1
Sat = 1
x = x + 1
Next
End Sub
Excelin sıralama özelligini kulanmayı denedim sanırım sayıların arasında noktalar ile ayrıldıgından tam olarak sıralama yapamadı birde kod hata verdi veya ben yapamadım