E TOPLA VE ÇOK E TOPLAYI MAKRO İLE KURGULAMAK

[taneryuksell]

Sevgili uzman arkadaşlarım eklediğim tabloda AÇILIŞ ve DETAY isminde kaynak sayfalarım bir de ÖZET isminde bir hedef sayfam var. Kaynaktaki verileri e topla veya çok e topla gibi formüllerle özete topluyorum. eklediğim dosya boyutunda bu bir problem değil ama en küçük dosyam bile 300 bin satırları aşıyor ve formül işlemiyor artık. Bu işlem bittikten sonra ÖZET sayfasını başka bir çalışma dosyasına kaydırıp daha rahat çalışabiliyorum ama işlemi tamamlayabilmek çok sıkıntı benim için. Bunu makro ile çözmek mümkün mü ? Saygılarımla..

 

[Ziynettin]

Dosyanız ekte.

Sub Toplam_AL()
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim a(), b(), c()
Set s1 = Sheets("AÇILIŞ")
Set s2 = Sheets("DETAY")
Set s3 = Sheets("ÖZET")

a = s1.Range("A2:M" & s1.Cells(Rows.Count, 1).End(3).Row).Value
b = s2.Range("A2:M" & s2.Cells(Rows.Count, 1).End(3).Row).Value
c = s3.Range("B1:Y" & s3.Cells(Rows.Count, 2).End(3).Row).Value

Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d5 = CreateObject("scripting.dictionary")
Set d6 = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        krt = CStr(a(i, 1))
        d1(krt) = d1(krt) + a(i, 7)
        d2(krt) = d2(krt) + a(i, 8)
        krt1 = krt & "|" & a(i, 10)
        If a(i, 10) = "TL" Then sut = 7 Else sut = 11
        d5(krt1) = d5(krt1) + a(i, sut)
        d6(krt1) = d6(krt1) + a(i, sut + 1)
    Next i

Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
Set d7 = CreateObject("scripting.dictionary")
Set d8 = CreateObject("scripting.dictionary")
    For i = 1 To UBound(b)
        krt = CStr(b(i, 1))
        d3(krt) = d3(krt) + b(i, 7)
        d4(krt) = d4(krt) + b(i, 8)
        krt1 = krt & "|" & b(i, 10)
        If b(i, 10) = "TL" Then sut = 7 Else sut = 11
        d7(krt1) = d7(krt1) + CDbl(b(i, sut))
        d8(krt1) = d8(krt1) + CDbl(b(i, sut + 1))
    Next i
    
On Error Resume Next
sat = UBound(c) - 3
ReDim v(1 To sat, 1 To UBound(c, 2))
For i = 4 To UBound(c)
    krt = CStr(c(i, 1))
    v(i - 3, 1) = d1(krt) - d2(krt)
    v(i - 3, 2) = d3(krt) + 0
    v(i - 3, 3) = d4(krt) + 0
    v(i - 3, 4) = (d1(krt) - d2(krt)) + d3(krt) - d4(krt)
    For j = 8 To UBound(c) Step 4
        krt1 = krt & "|" & c(1, j)
        v(i - 3, j - 3) = d5(krt1) - d6(krt1)
        v(i - 3, j - 2) = d7(krt1) + 0
        v(i - 3, j - 1) = d8(krt1) + 0
        v(i - 3, j) = (d5(krt1) - d6(krt1)) + d7(krt1) - d8(krt1)
    Next j
Next i
s3.[E4].Resize(sat, UBound(c, 2)) = v
MsgBox "işlem bitti...", vbInformation
End Sub

 

[taneryuksell]

Ziynettin hocam ellerine sağlık. Bu tam istediğim gibi bir tablo. Çok çok tşk ederim

 

[Ziynettin]

300 bin satır veride sonuç süresi nedir.

 

[taneryuksell]

Üstad şöyle bir durumla karşılaştım. Sütunlar aynı ama bazen satır aralarında boşluklar olabiliyor. Ben böyle bir tabloyu yükleyince hata verdi şuraya yönlendirdi: b = s2.Range("A2:M" & s2.Cells(Rows.Count, 1).End(3).Row).Value Bu aralıklarla ilgili olabilir mi ?

 

[Ziynettin]

Boş olan satırlar hangi sütunda ya da hatalı dosyayı görmek gerekir.

 

[taneryuksell]

Eklediğim gibi dosya. Bunların düzenlenmiş halleri ile ham hallerinin sütunları aynı tek fark satır boşlukları da olması. Belki sütunlar aynı olunca düzenlemeden özete çekebileceğimi düşündüm.

 

[Ziynettin]

b = s2.Range("A2:M" & s2.Cells(Rows.Count, 1).End(3).Row).Value2 şeklinde deneyin.

 

[taneryuksell]

Ziynettin hocam yazmış olduğunuz kısmı değiştirdim. Evet şimdi oldu artık sıkıntı yok. Birde süre sormuştunuz ben 400 bin satırda denedim. 10-12 saniye civarında özeti veriyor. Çok tşk ederim size.