..:: Benzersiz DAĞILIM ( 10 'lu ) ::..

Ömer BARAN · 29 Nisan 2014

Daha evvel benzer (5 sütunlu) bir konu açmıştım ve formül ile sonuç alınmıştı.
(Ekteki belgenin bir sayfası buna ilişkin çözümü içermektedir ve Destek Ekibi'nden mucit77'nin getirdiği çözüm ilgili konunun linki BURASI)
Ancak şimdi ihtiyaç değiştiğinden yeni konu açıyorum.

Sütunlarımda sırasıyla; 1, 2, 3, ..... 10 değer (metinsel) var.
Her sütundan sadece ilgili sütundaki seçeneklerden birini alarak benzersiz dağılım listesi oluşturmam gerekiyor.

Hesapladığıma göre oluşan seçenek sayısı (sütunlardaki eleman sayılarının çarpımı olan)
=ÇARPINIM(10)=> 3.628.800 ( yani 10! )ve excel sayfasındaki satır sınırı dolayısıyla bu dağılım listesinin 4 sayfaya yerleştirilmesi lazım.

Ekteki belgede gerekli açıklamayı yaptım.

Sanırım bu konuyu formülle çözmek mümkün olsa bile en azından belgeyi yavaşlatacaktır.
Bu yüzden konuyu Makro-VBA başlığı altında açtım.

NOT: Buradaki veri adetleri en fazla halidir. A sütunu için mutlaka 1, B sütunu için en fazla 2, C sütunu için en fazla 3,......J sütunu için en fazla 10 seçenek olabilecektir.

İlgilenecek site üye ve yöneticilerine şimdiden teşekkürler.

ÖmerBey · 29 Nisan 2014

Merhaba,
Makro isterseniz aşağıdaki kodu kullanabilirsiniz. Ancak çok çok uzun sürüyor, haberiniz olsun...

Kod:

Sub skjnds()
DoEvents
Dim a As Byte
Dim b As Byte
Dim c As Byte
Dim d As Byte
Dim e As Byte
Dim f As Byte
Dim g As Byte
Dim h As Byte
Dim i As Byte
Dim j As Byte
Dim y As Byte
Dim say As Long
Dim x As Long
Application.ScreenUpdating = False
x = 4
y = 1
say = 1
Set ds = Sheets("DAĞILIM.SORU")
Set d1 = Sheets("DA." & y)
For a = 1 To 1
    k1 = ds.Cells(a, 1)
    For b = 1 To 2
        k2 = ds.Cells(b, 2)
        For c = 1 To 3
            k3 = ds.Cells(c, 3)
            For d = 1 To 4
                k4 = ds.Cells(d, 4)
                For e = 1 To 5
                    k5 = ds.Cells(e, 5)
                    For f = 1 To 6
                        k6 = ds.Cells(f, 6)
                        For g = 1 To 7
                            k7 = ds.Cells(g, 7)
                            For h = 1 To 8
                                k8 = ds.Cells(h, 8)
                                For i = 1 To 9
                                    k9 = ds.Cells(i, 9)
                                    For j = 1 To 10
                                        k10 = ds.Cells(j, 10)
                                        If x = 1000004 Then
                                            x = 4
                                            y = y + 1
                                            Set d1 = Sheets("DA." & y)
                                        End If
                                        d1.Cells(x, 1) = k1
                                        d1.Cells(x, 2) = k2
                                        d1.Cells(x, 3) = k3
                                        d1.Cells(x, 4) = k4
                                        d1.Cells(x, 5) = k5
                                        d1.Cells(x, 6) = k6
                                        d1.Cells(x, 7) = k7
                                        d1.Cells(x, 8) = k8
                                        d1.Cells(x, 9) = k9
                                        d1.Cells(x, 10) = k10
                                        d1.Cells(x, 12) = say
                                        d1.Cells(x, 14) = k1 & "," & k2 & "," & k3 & "," & k4 & "," & k5 & "," & k6 & "," & k7 & "," & k8 & "," & k9 & "," & k10
                                        x = x + 1
                                        say = say + 1
                                    Next
                                Next
                            Next
                        Next
                    Next
                Next
            Next
        Next
    Next
Next
MsgBox "Tamam."
End Sub

Ömer BARAN · 30 Nisan 2014

Teşekkürler ancak....

mucit77' Alıntı:
Merhaba,
Makro isterseniz aşağıdaki kodu kullanabilirsiniz. Ancak çok çok uzun sürüyor, haberiniz olsun...

Kod:

Sub skjnds() MsgBox "Tamam." End Sub

Sayın mucit77 ilgi ve destek için teşekkürler.
Ancak sizin de söylediğiniz gibi makroyu çalıştırdım, yemeğimi, üstüne çayımı içtim hala devam ettiğini gördüm ve ESC ile durdurarak yapılan kısmı gördüm, ardından verilerin boşluklu biçimde olabileceğini de düşünerek verileri seyreltip makroyu tekrar çalıştırdığımda da boşlukları da dağıtıma tabi tuttuğunu ve süre kısalması sonucunu doğurmadığını gördüm. Boşluklu hali, konuyu açarken göz ardı ettiğim için doğal olarak kod da bu durumu kaale almadan çalıştı ve yine epeyce bekledim ve yine ESC ile durdurmak zorunda kaldım.

Size fazla zahmet veriyorum sanırım ama eklediğim yeni belgeye bakabilirseniz sevinirim. Seçenek sayısının bir sayfadaki satır sayısını aşmasını da temin etmek üzere;
-- sütun sayısını 10'dan 12'ye çıkarttım,
-- sütunlarda olabilecek seçenek adetlerine ilişkin sınırlama ekledim. Bu sınırlamalar ekteki yeni belgede yazılı.
Neticede yeni belgedeki en yüksek seçenek sayısını 884.736 adet olacak şekilde değiştirdim.
Boşluklu düzeni önce boşluksuz hale getirip ardından boşluksuz hal üzerinden önceki makrodakinin aynısının çalıştırılmasının süre olarak kısa süreceğini düşünüyorum. Zira seçenek sayısı artık 1 sayfaya sığacak miktarda.
Bu nedenle makro kodunda değişikliğe ihtiyaç oluştu.
İlgi ve destek için tekrar teşekkürler.

Konu açılış sayfasına yeni hale uygun belgeyi ekleyecektim ( 12'li SINIRLI olan) ama nedenini anlayamadım şu anda ek dosya gönderemiyorum .

Ömer BARAN · 30 Nisan 2014

Sayın mucit77 tekrar merhabalar...

mucit77' Alıntı:
Merhaba,
Makro isterseniz aşağıdaki kodu kullanabilirsiniz. Ancak çok çok uzun sürüyor, haberiniz olsun...

Kod:

Sub skjnds() MsgBox "Tamam." End Sub

Yeni belgeyi şimdi ekleyebildim.

ÖmerBey · 1 Mayıs 2014

Yeni dosyanız için kodlar:
Boşluklar atlanarak yapılan dağıtım için (Boşluksuz hale getirmeden)

Kod:

Sub Dağılım()
DoEvents
Dim a As Byte
Dim b As Byte
Dim c As Byte
Dim d As Byte
Dim e As Byte
Dim f As Byte
Dim g As Byte
Dim h As Byte
Dim i As Byte
Dim j As Byte
Dim k As Byte
Dim l As Byte
Dim say As Long
Dim x As Long
Application.ScreenUpdating = False
ay = ", "
x = 3
say = 1
Set ds = Sheets("DAĞILIM.SORU")
Set d1 = Sheets("DA.1")
d1.Range("A3:P1000000").ClearContents
For a = 2 To 2
    k1 = ds.Cells(a, 1)
    For b = 2 To 3
        If ds.Cells(b, 2) <> "" Then k2 = ds.Cells(b, 2) Else GoTo 2
        For c = 2 To 4
            If ds.Cells(c, 3) <> "" Then k3 = ds.Cells(c, 3) Else GoTo 3
            For d = 2 To 5
                If ds.Cells(d, 4) <> "" Then k4 = ds.Cells(d, 4) Else GoTo 4
                For e = 2 To 6
                    If ds.Cells(e, 5) <> "" Then k5 = ds.Cells(e, 5) Else GoTo 5
                    For f = 2 To 7
                        If ds.Cells(f, 6) <> "" Then k6 = ds.Cells(f, 6) Else GoTo 6
                        For g = 2 To 8
                            If ds.Cells(g, 7) <> "" Then k7 = ds.Cells(g, 7) Else GoTo 7
                            For h = 2 To 9
                                If ds.Cells(h, 8) <> "" Then k8 = ds.Cells(h, 8) Else GoTo 8
                                For i = 2 To 10
                                    If ds.Cells(i, 9) <> "" Then k9 = ds.Cells(i, 9) Else GoTo 9
                                    For j = 2 To 11
                                        If ds.Cells(j, 10) <> "" Then k10 = ds.Cells(j, 10) Else GoTo 10
                                        For k = 2 To 12
                                            If ds.Cells(k, 11) <> "" Then k11 = ds.Cells(k, 11) Else GoTo 11
                                            For l = 2 To 13
                                                If ds.Cells(l, 12) <> "" Then k12 = ds.Cells(l, 12) Else GoTo 12
                                                
                                                d1.Cells(x, 1) = k1
                                                d1.Cells(x, 2) = k2
                                                d1.Cells(x, 3) = k3
                                                d1.Cells(x, 4) = k4
                                                d1.Cells(x, 5) = k5
                                                d1.Cells(x, 6) = k6
                                                d1.Cells(x, 7) = k7
                                                d1.Cells(x, 8) = k8
                                                d1.Cells(x, 9) = k9
                                                d1.Cells(x, 10) = k10
                                                d1.Cells(x, 11) = k11
                                                d1.Cells(x, 12) = k12
                                                d1.Cells(x, 14) = say
                                                d1.Cells(x, 16) = k1 & ay & k2 & ay & k3 & ay & k4 & ay & k5 & ay & k6 & ay & k7 & ay & k8 & ay & k9 & ay & k10 & ay & k11 & ay & k12
                                                x = x + 1
                                                say = say + 1
12
                                            Next
11
                                        Next
10
                                    Next
9
                                Next
8
                            Next
7
                        Next
6
                    Next
5
                Next
4
            Next
3
        Next
2
    Next
1
Next
MsgBox "Tamam."
End Sub

Boşluksuz hale getirerek dağıtım yapmak için:

Kod:

Sub Dağ()
DoEvents
Dim a As Byte
Dim b As Byte
Dim c As Byte
Dim d As Byte
Dim e As Byte
Dim f As Byte
Dim g As Byte
Dim h As Byte
Dim i As Byte
Dim j As Byte
Dim k As Byte
Dim l As Byte
Dim say As Long
Dim x As Long
Application.ScreenUpdating = False
ay = ", "
x = 3
say = 1
Set ds = Sheets("DAĞILIM.SORU")
Set d1 = Sheets("DA.1")
d1.Range("A3:P1000000").ClearContents
ds.Range("A18:L22").ClearContents

p = 18
For q = 1 To 12
    For r = 2 To 13
        If ds.Cells(r, q) <> "" Then
            ds.Cells(p, q) = Cells(r, q)
            p = p + 1
        End If
    Next
    p = 18
Next


For a = 18 To Range("A22").End(3).Row
    k1 = ds.Cells(a, 1)
    For b = 18 To Range("B22").End(3).Row
        k2 = ds.Cells(b, 2)
        For c = 18 To Range("C22").End(3).Row
            k3 = ds.Cells(c, 3)
            For d = 18 To Range("D22").End(3).Row
                k4 = ds.Cells(d, 4)
                For e = 18 To Range("E22").End(3).Row
                    k5 = ds.Cells(e, 5)
                    For f = 18 To Range("F22").End(3).Row
                        k6 = ds.Cells(f, 6)
                        For g = 18 To Range("G22").End(3).Row
                            k7 = ds.Cells(g, 7)
                            For h = 18 To Range("H22").End(3).Row
                                k8 = ds.Cells(h, 8)
                                For i = 18 To Range("I22").End(3).Row
                                    k9 = ds.Cells(i, 9)
                                    For j = 18 To Range("J22").End(3).Row
                                        k10 = ds.Cells(j, 10)
                                        For k = 18 To Range("K22").End(3).Row
                                            k11 = ds.Cells(k, 11)
                                            For l = 18 To Range("L22").End(3).Row
                                                k12 = ds.Cells(l, 12)
                                                
                                                d1.Cells(x, 1) = k1
                                                d1.Cells(x, 2) = k2
                                                d1.Cells(x, 3) = k3
                                                d1.Cells(x, 4) = k4
                                                d1.Cells(x, 5) = k5
                                                d1.Cells(x, 6) = k6
                                                d1.Cells(x, 7) = k7
                                                d1.Cells(x, 8) = k8
                                                d1.Cells(x, 9) = k9
                                                d1.Cells(x, 10) = k10
                                                d1.Cells(x, 11) = k11
                                                d1.Cells(x, 12) = k12
                                                d1.Cells(x, 14) = say
                                                d1.Cells(x, 16) = k1 & ay & k2 & ay & k3 & ay & k4 & ay & k5 & ay & k6 & ay & k7 & ay & k8 & ay & k9 & ay & k10 & ay & k11 & ay & k12
                                                x = x + 1
                                                say = say + 1
12
                                            Next
11
                                        Next
10
                                    Next
9
                                Next
8
                            Next
7
                        Next
6
                    Next
5
                Next
4
            Next
3
        Next
2
    Next
1
Next
MsgBox "Tamam."
End Sub

Arasında sadece birkaç saniye oynuyor, artık hangisini kullanmak isterseniz.

Muhammet Okumuş · 1 Mayıs 2014

Merhaba, alternatif olarak kodu deneyiniz.

Sub Dağılım()
Application.ScreenUpdating = False
Sheets(2).Range("A3:L1048576") = ""
Range("A18:L29") = Range("A2:L13").Value
Range("A18:L29").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Range("A15:L15") = "=COUNTA(A18:A29)"
Range("L16") = 1
Range("A16:K16") = "=B15*B16"
x = Evaluate("PRODUCT(A15:L15)+2")
Sheets(2).Select

Range("A3:L" & x) = "=OFFSET(DAĞILIM.SORU!A$17,IF(MOD(ROUNDUP(ROW($A1)/DAĞILIM.SORU!A$16,0),DAĞILIM.SORU!A$15)=0,DAĞILIM.SORU!A$15,MOD(ROUNDUP(ROW($A1)/DAĞILIM.SORU!A$16,0),DAĞILIM.SORU!A$15)),0)"
Range("A3:L" & x) = Range("A3:L" & x).Value
End Sub

Kodu deneyiniz.

Ömer BARAN · 1 Mayıs 2014

Muhammet Okumuş' Alıntı:
Merhaba, alternatif olarak kodu deneyiniz.

Kodu deneyiniz.

Sayın Okumuş, kodu uygulamaya çalıştım ama sanırım;
- sayfa isimleriyle ilgili ya da
- orijinal belgemde DAĞILIM.SORU sayfasındaki dağıtılacak veriler (birinci satır başlık satırı) A2:L13 aralığında ve buradaki veriler formüllerle oluşmaktadır, yani boş hücreler aslında gerçekten boş değil, boş sonuç üreten formüller mevcut olduğundan bununla ilgili
bir sorun var.
Dağılımın yapılacağı sayfa DA.1 adlı sayfa.
Örnek dosyada verilerdeki boşlukların dikkate alınmamasını vurgulamak maksadıyla, A18:L21 aralığına elle yazılmış şekildedir.
Kodu nasıl değiştirmek lazım acaba? Ya da ben nerede hata yapıyorum?

Ömer BARAN · 1 Mayıs 2014

...... Hata......

Muhammet Okumuş · 1 Mayıs 2014

Formüller boş gösteren hücre olsa dahi sorun olmaması gerekiyor.

Ömer BARAN · 1 Mayıs 2014

Muhammet Okumuş' Alıntı:
Formüller boş gösteren hücre olsa dahi sorun olmaması gerekiyor.

Ben kodu verilerin yer aldığı DAĞILIM.SORU sayfasının kod kısmına yapıştırdım. Aynı sayfadaki butona makroyu atadım ve çalıştırdım.
Birkaç saniye sonra oluşan sonuç resimdeki gibi.
Resimdeki A2:L2 aralığındaki sonuçlar DEĞER hatası şeklinde.
Ayrıca dağılımın, verilerin olduğu sayfaya değil DA.1 adlı sayfaya A3 hücresinden itibaren (ilk iki satır başlık satırı) yerleşmesi lazımdı.

Muhammet Okumuş · 1 Mayıs 2014

Pardon ben o kısımda düzenleme yapmıştım. Dosyayı inceleyiniz.

Ömer BARAN · 1 Mayıs 2014

Muhammet Okumuş' Alıntı:
Pardon ben o kısımda düzenleme yapmıştım. Dosyayı inceleyiniz.

Sayın Okumuş sanırım ben beceremiyorum.
Dağılım sonucunun DA.1 sayfasına yazılması lazım idi. Dosyayı tekrar gönderiyorum. Gönderdiğiniz belgenin aynısıdır. Dağılımın yazılacağı DA.1 sayfasındaki M sütunundan sonraki sütunlar gerekli değildir. Benzersizlik kontrolü amacıyla hazırlamıştım.

Mevcut haliyle benzersiz dağılım sayısı =ÇARPIM(P3:AA3) -> 884.736 adet olup bu sayı zaten düşündüğüm sınırlamanın en fazla halidir. Yani makronun DA.1 sayfasında bu kadar sayıda satıra veri yazması lazım.

Örneğin A sütunu için tek seçenek olduğundan ( 1.1 ) tüm satırlarda bu verinin tekrarlanması gerekiyor, bu verinin başka sütunda kullanılmaması ve de A sütununda da başka sütundaki verinin kullanılmaması lazım.

Ömer BARAN · 1 Mayıs 2014

Gece gece sizi de yoruyorum, kusura bakmayınız.

Muhammet Okumuş · 1 Mayıs 2014

Siz bir tane sayfa eklemişsiniz. Sheets(2) olan yerleri Sheets(3) yapınız. Veri sayınız çok olduğundan kodları parçalı yapmak gerekiyor.

Ömer BARAN · 1 Mayıs 2014

Verilerin formülle geldiğini netleştirmek için ekledim o sayfayı.
Söylediğim gibi seçenek sayısı ki bu değer maksimum sayıdır ve seçenek sayılarını çarpımı kadar.
=ÇARPIM(P3:AA3) -> 1*2*3*3*3*4*4*4*4*4*4*4 = 884.736

Excel versiyorum 2007 olduğundan 1 sayfaya sığmasında sorun yok. Elbette yorucu bir makro olacağı malum, 800.000 satırda mükerrerlik kontrolü yapılarak dağılım oluşturuluyor neticede.

Muhammet Okumuş · 1 Mayıs 2014

Yarın bakmaya çalışayım. Sizin için maksimum ne kadar sürede bitirmeli. Bir de bu kodaları çalıştırma aralığınız nedir?

Ömer BARAN · 1 Mayıs 2014

Verileri girip bir kez çalıştıracağım, sonra bu verileri kullanarak formüllerle hesaplamalar yaptırmam gerekiyor. Söylediğim gibi matris dağılımını ifade etmektedir ve her bir değer satır ve sütun numarasını temsil etmektedir. Bu satır ve sütun numaralarından hareketle matematiksel karşılaştırmalar ve hesaplamalar var.
İlgi ve destek için teşekkürler ediyorum, sizi de uykusuz bıraktım kusura bakmayın.
Sayın mucit77'nin ilettiği kod 20 dakika civarında tamamlıyor.

Sağlıcakla kalınız.

Bir kez daha çalıştırdım mucit'in kodunu bu kez 8 dakikada bitirdi.

Muhammet Okumuş · 1 Mayıs 2014

Kaç adet veriyi?

Ömer BARAN · 1 Mayıs 2014

Muhammet Okumuş' Alıntı:
Yarın bakmaya çalışayım. Sizin için maksimum ne kadar sürede bitirmeli. Bir de bu kodaları çalıştırma aralığınız nedir?

omer.baran' Alıntı:
Verileri girip bir kez çalıştıracağım, sonra bu verileri kullanarak formüllerle hesaplamalar yaptırmam gerekiyor. Söylediğim gibi matris dağılımını ifade etmektedir ve her bir değer satır ve sütun numarasını temsil etmektedir. Bu satır ve sütun numaralarından hareketle matematiksel karşılaştırmalar ve hesaplamalar var.

Sayın mucit77'nin ilettiği kod 20 dakika civarında tamamlıyor.
Bir kez daha çalıştırdım mucit'in kodunu bu kez 8 dakikada bitirdi.

Sayın Okumuş, dün hataen sizin gönderdiğiniz kod'dan bahsedeceğim yere Sayın mucut'in kod'undan bahsetmişim.
Doğru bilgi şöyle, sizin gönderdiğiniz kod verilerin maksimum haline göre oluşan yaklaşık 900.000 satırlık veriyi 8 dakikada tamamlıyor.

Benim DA.1 sayfamda, dağılım numarası (N sütunu) ve dağılım değerlerinin aralara "," eklenerek birleştirilmiş haline (P sütunu) ihtiyaç kalmamış oluyor.
Benim o sütunlardan maksadım benzersizliği kontrol edebilmek idi.

Dolayısıyla yazdığınız kod'un N ve P sütuna yazdığı verileri yazmayacak hale getirilmesi için nasıl düzenlenmesi lazım.

Bir de A:L sütunlarına veriler yazılırken; asıl verilerin arasında " . " varken DA.1 sayfasına kod tarafından yazılan değerlerin arasında " , " var. Bunun da değiştirilmesi gerekecek.

Gönderdiğiniz kod'da bu değişiklikler de yapılınca işlem süresi daha da kısalacaktır, çünkü veri yazılan sütun sayısı ve işlem adeti azalıyor ve karakter değişikliği de yapılmıyor olacak.

ÖmerBey · 1 Mayıs 2014

Ekteki dosyayı dener misiniz?
Formül ve makroyu birarada kullanınca süre epeyce kısaldı.

..:: Benzersiz DAĞILIM ( 10 'lu ) ::..

Uzman

Ekli dosyalar

Destek Ekibi

Uzman

Uzman

Ekli dosyalar

Destek Ekibi

Destek Ekibi

Uzman

Uzman

Destek Ekibi

Uzman

Ekli dosyalar

Destek Ekibi

Ekli dosyalar

Uzman

Ekli dosyalar

Uzman

Destek Ekibi

Uzman

Destek Ekibi

Uzman

Destek Ekibi

Uzman

Destek Ekibi

Ekli dosyalar