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

[Muhammet Okumuş]

Merhaba,

Sub Dağılım()
Application.ScreenUpdating = False
Sheets(2).Range("T2") = Now
Sheets(2).Range("A3:Q1048576") = ""
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

Sheets(2).Range("T3") = Now
a = Format(Range("T2"), "hh.mm.ss")
b = Format(Range("T3"), "hh.mm.ss")
MsgBox "Başlama : " & a & vbLf & vbLf & "Bitiş : " & b
End Sub

Kodu deneyin. Ben 884.000 civarı veri için denedim. Kaynak tükendi şeklinde hata verdi. Bilgisayarımın özelliklerinden midir acaba?

 

[Ömer BARAN]

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

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.

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; - haddimi aşarak - kodda değişiklikler yaptım.

Kodun yeni hali aşağıdaki hale geldi (Silmek yerine satır başlarna " ' " ekledim.
Kodu bir kez yukarıda söylediğim değişikliği yapmadan, bir kez de bu değişiklikten sonra iki kez çalıştırdım.
Her iki çalıştırmamda da işlemi tamamlamadan "Out of memory" hatasıyla kod çalışmayı kendiliğinden durdurdu ve DA.1 sayfasına baktığımda sonuçlar (A:L sütunları) tamam ama hücrelerde değer yerine; örneğin A3 hücresi için

=İNDİS(DAĞILIM.SORU!A$18:A$21;MOD(BÖLÜM(SATIR()-3;DAĞILIM.SORU!Q$4);DAĞILIM.SORU!P$3)+1)

formülünün durduğunu gördüm. (Liste boyunca diğer tüm hücrelerde de benzer formüller var.)
Sanırım değer yapıştırma gibi bir işlem eksik kalmış görünüyor.
Bir de DAĞILIM.SORU sayfası P4:AA4 aralığında makro kod'un kullandığını sandığım ve veri yazılacak satır sayısını hesaplayan formüller var. Bunların da yok edilmesi lazım. Sorun olabilir diye, manuel silmek istemedim.
Kodun yeni hali aşağıdaki hale geldi.

Sub Dağıt()
Set ds = Sheets("DAĞILIM.SORU")
Set d1 = Sheets("DA.1")

Application.ScreenUpdating = False
d1.Range("A3:L900000").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

Set alan1 = d1.Range("A3:L" & ds.Range("O3") + 2)
'Set alan2 = d1.Range("N3:N" & ds.Range("O3") + 2)
'Set alan3 = d1.Range("P3:P" & ds.Range("O3") + 2)
'Set alan4 = d1.Range("Q3:Q" & ds.Range("O3") + 2)
With alan1
    .Formula = "=INDEX(DAĞILIM.SORU!A$18:A$21,MOD(QUOTIENT(ROW()-3,DAĞILIM.SORU!Q$4),DAĞILIM.SORU!P$3)+1)"
    .Value = .Value
End With

'With alan2
'    .Formula = "=ROW()-2"
'    .Value = .Value
'End With

'With alan3
'    .Formula = "=CONCATENATE(A3,"", "",B3,"", "",C3,"", "",D3,"", "",E3,"", "",F3,"", "",G3,"", "",H3,"", "",I3,"", "",J3,"", "",K3,"", "",L3)"
'    .Value = .Value
'End With

Exit Sub

'With alan4
'    .Formula = "=COUNTIF(P$3:P3,P3)"
'   .Value = .Value
'End With
Application.ScreenUpdating = True
End Sub

 

[ÖmerBey]

Eğer değeriniz çoksa ondan olmuştur.
Hafıza hatası

With alan1
    .Formula = "=INDEX(DAĞILIM.SORU!A$18:A$21,MOD(QUOTIENT(ROW()-3,DAĞILIM.SORU!Q$4),DAĞILIM.SORU!P$3)+1)"
[COLOR="Red"]    .Value = .Value[/COLOR]
End With

Bu kısımdaki kırmızı kısım formülle elde edilen veriyi değere çeviriyor çok fazla veri olunca da hafıza yetmiyordur.
İsterseniz topluca değil de bir döngü ile tek tek değere çevrilebilir, ya da o satırı iptal edip formül kullanabilirsiniz.

 

[ÖmerBey]

İsteklerinize göre dosyanızı yeniden düzenledim.
Formülleri 10000 satırlık parçalar halinde değere çeviriyor.
Yine hafıza ile ilgili hatayı alırsanız kod içerisindeki ilgili bölümü azaltınız.
884 bin sonuç yaklaşık 2,5 dakika sürdü.

 

[Ömer BARAN]

Sayın mucit77, Sayın Okumuş yardım ve destek için teşekkürler ediyorum.
Sağlıcakla kalınız.