8 li kombinasyon

knnklc · 19 Mayıs 2018

Merhaba şu şekilde listeleme yapmak istiyorum. Örneğin alfabedeki tüm karakterleri kullanarak aynı karakteri tekrar tekrar içerecek şekilde oluşturmak istiyorum. Örneğin;

a a a a a a a a
a a a a a a a b....

Ancak yaptığım makroda listeye sığmıyor, ben ikinci sayfaya aktarılmasını istiyorum... Bu makroyu nasıl düzeltmeliyim.

Yaptığım Makro

Kod:

Sub Kombinasyon()
On Error Resume Next
Application.ScreenUpdating = False
Cells.ClearContents
x = 1
liste = InputBox("Kombinasyonlarını almak istediğiniz değerleri giriniz." & Chr(10) & "(Değerlerin arasını virgül ile ayırınız.)")
sayı = Split(liste, ",")
k = InputBox("Kaçlı kombinasyon yapmak istiyorsunuz?")
If k > 10 Then MsgBox "En fazla 10'lu kombinasyon oluşturabilirsiniz.", vbCritical: Exit Sub
For a = k To UBound(sayı) - 9
    For b = q To UBound(sayı) - 8
        For c = w To UBound(sayı) - 7
            For d = r To UBound(sayı) - 6
                For e = t To UBound(sayı) - 5
                    For f = y To UBound(sayı) - 4
                        For g = u To UBound(sayı) - 3
                            For h = o To UBound(sayı) - 2
                                For i = p To UBound(sayı) - 1
                                    For j = Z To UBound(sayı)
                                        Cells(x, k - 9) = sayı(a)
                                        Cells(x, k - 8) = sayı(b)
                                        Cells(x, k - 7) = sayı(c)
                                        Cells(x, k - 6) = sayı(d)
                                        Cells(x, k - 5) = sayı(e)
                                        Cells(x, k - 4) = sayı(f)
                                        Cells(x, k - 3) = sayı(g)
                                        Cells(x, k - 2) = sayı(h)
                                        Cells(x, k - 1) = sayı(i)
                                        Cells(x, k - 0) = sayı(j)
                                        x = x + 1
                                    Next
                                    If k = 1 Then GoTo son
                                Next
                                If k = 2 Then GoTo son
                            Next
                            If k = 3 Then GoTo son
                        Next
                        If k = 4 Then GoTo son
                    Next
                    If k = 5 Then GoTo son
                Next
                If k = 6 Then GoTo son
            Next
            If k = 7 Then GoTo son
        Next
        If k = 8 Then GoTo son
    Next
    If k = 9 Then GoTo son
Next
son:
Application.ScreenUpdating = True
End Sub

Haluk · 19 Mayıs 2018

Aşağıdaki linkte 21. mesajın ekindeki dosyayı deneyin ...

http://www.excel.web.tr/f50/kombinasyon-sonucunu-sayfalara-yazdyrabilirmiyiz-t36987/sayfa3.html

Kodları çalıştırmadan önce de; 5 mesajın sonundaki notu okuyup, gereğini yapın.

.

ÖmerBey · 19 Mayıs 2018

Merhaba,
Alfadeki tüm harfler 29 tane ve bunları 8 basamaklı tekrarlı olarak yazdırdığınızda 29^8 sonuç çıkar. Yani 500.246.412.961 tane. Bunu hesapladınız mı? 500 küsür milyar değeri kaç sayfaya yazdırmayı düşünüyorsunuz?

Haluk · 19 Mayıs 2018

ÖmerBey' Alıntı:
Merhaba,
Alfadeki tüm harfler 29 tane ve bunları 8 basamaklı tekrarlı olarak yazdırdığınızda 29^8 sonuç çıkar. Yani 500.246.412.961 tane.

Ömer Bey eğer ben yanlış anlamadıysam; 29 adet verinin 8'li kombinasyonu 4.292.145 olur. (Benim matematiksel olarak anladığım kombinasyondan bahsediliyorsa)

Kod:

=COMBIN(29;8)

Office 2010'da satır sayısı 1.048.576 olduğu için bu sonuçlar 4,09 adet sayfada yani 5 sayfada listelenir.

Satır sayısı 65.536 olan eski versiyonlarda ise, 66 sayfada listelenir. (PC'nin işlemcesi kodun çalışması için yeterliyse....)

.

.

ÖmerBey · 19 Mayıs 2018

Haklısınız Haluk Bey, ama sizin belirttiğiniz 29 verinin 8'li seçimi olan normal kombinasyon, konuyu açan arkadaş ise aaaaaaaa şeklinde tekrarlayan bir seçim istiyor. ilk mesajdaki verdiği örneğe bakarsanız orada belirtmiş. Bu durumda sonuç farklı olur.

knnklc · 19 Mayıs 2018

ÖmerBey' Alıntı:
Merhaba,
Alfadeki tüm harfler 29 tane ve bunları 8 basamaklı tekrarlı olarak yazdırdığınızda 29^8 sonuç çıkar. Yani 500.246.412.961 tane. Bunu hesapladınız mı? 500 küsür milyar değeri kaç sayfaya yazdırmayı düşünüyorsunuz?

500 sayfaya yazdırmayı düşüyorum.

ÖmerBey · 19 Mayıs 2018

O halde kolay gelsin, kodlar aşağıdadır.
İyi çalışmalar...

Kod:

Sub kod()
Application.ScreenUpdating = False
alf = Array("A", "B", "C", "Ç", "D", "E", "F", "G", "Ğ", "H", "I", "İ", "J", "K", "L", "M", "N", "O", "Ö", "P", "R", "S", "Ş", "T", "U", "Ü", "V", "Y", "Z")
Set S = ActiveSheet
For Each a In alf
    For Each b In alf
        For Each c In alf
            For Each d In alf
                For Each e In alf
                    For Each f In alf
                        For Each g In alf
                            For Each h In alf
                                x = x + 1
                                S.Cells(x, "A") = a
                                S.Cells(x, "B") = b
                                S.Cells(x, "C") = c
                                S.Cells(x, "D") = d
                                S.Cells(x, "E") = e
                                S.Cells(x, "F") = f
                                S.Cells(x, "G") = g
                                S.Cells(x, "H") = h
                                If x = 1000000 Then
                                    Sheets.Add After:=Sheets(Sheets.Count)
                                    Set S = ActiveSheet
                                    x = 0
                                End If
                            Next
                        Next
                    Next
                Next
            Next
        Next
    Next
Next
Application.ScreenUpdating = True
End Sub

shiva · 1 Haziran 2018

benim sorum da bu konudaki soruya benzer ama kodu oluşturamadım.

AİRSTONE harflerinden anlamlı/anlamsız sadece 3 ve 4 harfli kaç sözcük oluşturabilirim ve bunlar neler olur?

kod olarak verebilirseniz çok makbüle geçer. Teşekkürler şimdiden.

Haluk · 1 Haziran 2018

shiva' Alıntı:
benim sorum da bu konudaki soruya benzer ama kodu oluşturamadım.

AİRSTONE harflerinden anlamlı/anlamsız sadece 3 ve 4 harfli kaç sözcük oluşturabilirim ve bunlar neler olur?

2 No'lu mesajı gördünüz mü?

.

shiva · 1 Haziran 2018

2 nolu mesajdaki linke gidiyorum ama çözüme ulaşmak için sanırım dosya indirmek gerekiyor. Onun için de altın üyelik yapmamız lazım.

Cebimden para çıkmadan bu sorunun çözümü konusunda destek alamıyor muyum buradan?

ÖmerBey · 1 Haziran 2018

Merhaba,
Diğer mesajınızdan anladığım kadarıyla aşağıdaki kod işinizi görür. 3'lü için kırmızı kısımları silin.

Rich (BB code):

Sub kod()
Application.ScreenUpdating = False
alf = Array("A", "I", "R", "S", "T", "O", "N", "E")
Set S = ActiveSheet
For Each a In alf
    For Each b In alf
        If b = a Then GoTo 2
        For Each c In alf
            If c = b Or c = a Then GoTo 3
            For Each d In alf
                If d = c Or d = b Or d = a Then GoTo 4
                x = x + 1
                S.Cells(x, "A") = a & b & c & d
4
            Next
3
        Next
2
    Next
1
Next
Application.ScreenUpdating = True
End Sub

ÖmerBey · 1 Haziran 2018

Anahtar kelimenizde aynı harften birden fazla olursa aşağıdaki kodu kullanabilirsiniz.

Kod:

Sub kod()
Application.ScreenUpdating = False
alf = Array("A", "I", "R", "S", "T", "O", "N", "E")
Set S = ActiveSheet
For a = LBound(alf) To UBound(alf)
    For b = LBound(alf) To UBound(alf)
        If b = a Then GoTo 2
        For c = LBound(alf) To UBound(alf)
            If c = b Or c = a Then GoTo 3
            For d = LBound(alf) To UBound(alf)
                If d = c Or d = b Or d = a Then GoTo 4
                x = x + 1
                S.Cells(x, "A") = alf(a) & alf(b) & alf(c) & alf(d)
4
            Next
3
        Next
2
    Next
1
Next
Application.ScreenUpdating = True
End Sub

shiva · 2 Haziran 2018

işe yaradı çok teşekkür ediyorum.

shiva · 2 Haziran 2018

ÖmerBey' Alıntı:

Anahtar kelimenizde aynı harften birden fazla olursa aşağıdaki kodu kullanabilirsiniz.

Kod:

Sub kod()
Application.ScreenUpdating = False
alf = Array("A", "I", "R", "S", "T", "O", "N", "E")
Set S = ActiveSheet
For a = LBound(alf) To UBound(alf)
    For b = LBound(alf) To UBound(alf)
        If b = a Then GoTo 2
        For c = LBound(alf) To UBound(alf)
            If c = b Or c = a Then GoTo 3
            For d = LBound(alf) To UBound(alf)
                If d = c Or d = b Or d = a Then GoTo 4
                x = x + 1
                S.Cells(x, "A") = alf(a) & alf(b) & alf(c) & alf(d)
4
            Next
3
        Next
2
    Next
1
Next
Application.ScreenUpdating = True
End Sub

Ömer Bey Merhabalar,

Sonuçlarda aynı harfleri içeren kayıtlar bulunmuyor. Mesela AAAA, İİİİ veya ASSA gibi. Yani anahtar kelimede geçen her harfi birden fazla kez kullanabiliriz. Tam olarak istediğim kombinasyon değil permütasyon olmalı.

Kodu nasıl değiştirmemiz gerekiyor acaba?

----------
Edit: Anahtar Kelimeden geçen harfleri 4 er kez en üstte yer alan bölüme yazarak 860k lık bir liste oluşturdum. Tabi burda yinelenenler vardı.
Yinelenleri kaldırınca 4096 adet istediğim listeye ulaştım.

Haluk · 2 Haziran 2018

Ömer Beyin 7 No'lu mesjındaki kod, isteğinize göre uyarlanmıştır ....

Kod:

Sub kod2()
    Application.ScreenUpdating = False
        alf = Array("A", "I", "R", "S", "T", "O", "N", "E")
        Set S = ActiveSheet
        For Each a In alf
            For Each b In alf
                For Each c In alf
                    For Each d In alf
                        x = x + 1
                        S.Cells(x, "A") = a
                        S.Cells(x, "B") = b
                        S.Cells(x, "C") = c
                        S.Cells(x, "D") = d
                    Next
                Next
            Next
        Next
    Application.ScreenUpdating = True
End Sub

.

shiva · 3 Haziran 2018

Haluk' Alıntı:

Ömer Beyin 7 No'lu mesjındaki kod, isteğinize göre uyarlanmıştır ....

Kod:

Sub kod2()
    Application.ScreenUpdating = False
        alf = Array("A", "I", "R", "S", "T", "O", "N", "E")
        Set S = ActiveSheet
        For Each a In alf
            For Each b In alf
                For Each c In alf
                    For Each d In alf
                        x = x + 1
                        S.Cells(x, "A") = a
                        S.Cells(x, "B") = b
                        S.Cells(x, "C") = c
                        S.Cells(x, "D") = d
                    Next
                Next
            Next
        Next
    Application.ScreenUpdating = True
End Sub

.

Haluk Bey Merhaba,

Öncelikle teşekkür ediyorum ama sizin kodu çalıştırınca A satırındaki KNK sütünuna gidiyor ve orda kalıyor boş şekilde.

Haluk · 3 Haziran 2018

A-B-C-D sütunlarında veriler listelenmiyor mu ???

Örnek dosyayı aşağıdaki linkten indirebilirsiniz...

https://drive.google.com/open?id=1GS6r6uUPD5MLcWHtKl5QdxY5b0y5rbNO

.

ÖmerBey · 10 Mayıs 2019

Başka bir proje için yazmıştım. Alternatif olarak burada da dursun.
İyi çalışmalar...

AAA şeklinde tekrarlı veri elde etmek için:

PHP:

Sub kod()
Application.ScreenUpdating = False
seri = Array("A", "I", "R", "S", "T", "O", "N", "E")
Dim s()
Dim a As Integer, bas As Byte, x As Long, m As String
bas = Application.InputBox("Kaç basamak olsun", Type:=1)
If bas = False Then Exit Sub
Range("A:A").ClearContents

ReDim s(1 To bas)
For a = LBound(s) To UBound(s)
    s(a) = LBound(seri)
Next

Do
    For a = LBound(s) To UBound(s)
        m = m & seri(s(a))
    Next
   
    x = x + 1
    Cells(x, 1) = m
    m = ""
    s(UBound(s)) = s(UBound(s)) + 1
    If s(UBound(s)) > UBound(seri) Then
        For a = UBound(s) To LBound(s) + 1 Step -1
            If s(a) > UBound(seri) Then
                s(a - 1) = s(a - 1) + 1
                s(a) = LBound(seri)
            End If
        Next
        If s(LBound(s)) > UBound(seri) Then GoTo 1
    Else
       
    End If
Loop While x < Rows.Count
1
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

Kombinasyon için:

PHP:

Sub kod()
Application.ScreenUpdating = False
seri = Array("A", "I", "R", "S", "T", "O", "N", "E")
Dim s()
Dim a As Integer, bas As Byte, x As Long, m As String
bas = Application.InputBox("Kaç basamak olsun", Type:=1)
If bas = False Then Exit Sub
Range("A:A").ClearContents

ReDim s(1 To bas)
For a = LBound(s) To UBound(s)
    s(a) = LBound(seri) + a - 1
Next

Do
    For a = LBound(s) To UBound(s)
        m = m & seri(s(a))
    Next
   
    x = x + 1
    Cells(x, 1) = m
    m = ""
    s(UBound(s)) = s(UBound(s)) + 1
    If s(UBound(s)) > UBound(seri) Then
        For a = UBound(s) To LBound(s) + 1 Step -1
            If s(a) > UBound(seri) - (UBound(s) - a) Then
                s(a - 1) = s(a - 1) + 1
                s(a) = 0
            End If
        Next
        For a = LBound(s) + 1 To UBound(s)
            If s(a) = 0 Then s(a) = s(a - 1) + 1
        Next
        If s(LBound(s)) > UBound(seri) - bas + 1 Then GoTo 1
    End If
Loop While x < Rows.Count
1
Application.ScreenUpdating = True
MsgBox "bitti"
End Sub

8 li kombinasyon

knnklc

Haluk

Özel Üye

ÖmerBey

Destek Ekibi

Haluk

Özel Üye

ÖmerBey

Destek Ekibi

knnklc

ÖmerBey

Destek Ekibi

shiva

Haluk

Özel Üye

shiva

ÖmerBey

Destek Ekibi

ÖmerBey

Destek Ekibi

shiva

shiva

Haluk

Özel Üye

shiva

Haluk

Özel Üye

ÖmerBey

Destek Ekibi