Tarih Aralığını Belli Kritere Göre Toplama

[ZuCChiNi]

Ekteki dosyada GELİR ve GİDER kalemlerini ilgili sekmelere alıp TOPLA.ÇARPIM fonksiyonu ile aylara göre toplamını alıyorum (excel.ewb.tr sayesinde ).
Ancak gelir ve gider kalemleri çok olduğundan hem dosya boyutu büyüyor, hem de bilgi girişleri uzun sürüyor. (Özellikle Geri Al dediğim zaman)

Bu işlemi kullandığım makro ile yapmam mümkün mü?
Bu konuda yardımınızı rica ediyorum.

 

[askm]

http://www.excel.web.tr/f48/tarih-aralyoynda-gelir-gider-hesaplatma-t159786.html Bu linki inceleyin.

 

[muygun]

Merhaba;
Alternatif:
Eki deneyin.
İyi çalışmalar.

Not: Veri tabanında farklı yıllara ait veri olabileceği varsayılarak ikinci ek oluşturuldu.

 

[Ziynettin]

Merhaba,
Alternatif olarak ekli dosyayı deneyin.

 

[ZuCChiNi]

@askm, @muygun ve @Ziynettin ayrı ayrı teşekkür ediyorum.
@muygun yapmak istediğimi doğru tahmin etmişsiniz. Farklı yıllara göre sekmelerim var.
Yıllara göre farklı analizleri de hazırlıyordum. Hazırlamak 4 saatimi almıştı. Bu daha iyi oldu.
Bu arada @Ziynettin'in makrosu daha hızlı çalışıyor.

Tekrar teşekkür ediyorum.

 

[ZuCChiNi]

Kullanış itibarı ile @Ziynettin'in çalışması hoşuma gitmişti. Ancak toplamların yanlış olduğunu farkettim.
GELİR toplamlarını alırken GELİR kalemlerini değil de borç sütunundakilerin tamamını topluyor ve
alakasız kalemlere ekliyor. Büyük ihtimalle GİDER toplamlarında da böyle bir hata var çünkü onda da
alacak sütunundaki rakamların tamamı toplanıyor. Kodu kurcaladım ama el yordamı ile olmuyor maalesef.

Bunu düzeltmemiz mümkün müdür?

Kullanmakta olduğum dosyayı ekte gönderiyorum.
Toplamların doğru şekli GelirlerDoğrusu sekmesinde.

 

[Ziynettin]

Aktar kodunda toplamları aranan kriter [GELİR/GİDER] dışında olması nedeni, düzeltilmiş hali...

Sub aktar()
Dim a(), b(), d1 As Object, d2 As Object
Dim Sat As Long, Sut As Long, Say1 As Long, Say2 As Long
Dim i As Long, j As Long, Krt, s1 As Worksheet
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set s1 = Sheets("2012")
Sat = 1
Sut = 1
Say1 = Sat
Say2 = Sut
Application.ScreenUpdating = False
a = s1.Range("A4:Q" & s1.Cells(Rows.Count, 1).End(3).Row)
ReDim b(1 To UBound(a), 1 To 12)
    For i = 1 To UBound(a)
[COLOR="Red"]    If a(i, 2) = Aranan Then[/COLOR]
        If d1.exists(a(i, 17)) Then
            Sat = d1(a(i, 17))
        Else
            d1(a(i, 17)) = Say1
            Sat = Say1
            Say1 = Say1 + 1
            
        End If
    Krt = Month(a(i, 7))
        If d2.exists(Krt) Then
            Sut = d2(Krt)
        Else
            d2(Krt) = Say2
            Sut = Say2
            Say2 = Say2 + 1
        End If
[COLOR="Red"]        b(Sat, Sut) = b(Sat, Sut) + a(i, Sutun)
       End If[/COLOR]
    Next i
    With Sheets(Syf)
        .Range("A2:N" & Rows.Count).Clear
        .[A2] = Syf:  .[N2] = "Toplam"
        .[A2:N2].Font.Bold = True
        .[A3].Resize(d1.Count) = Application.Transpose(d1.keys)
        .[B2].Resize(, d2.Count) = d2.keys
        .[B3].Resize(d1.Count, d2.Count) = b
        .[B3].Resize(d1.Count, d2.Count + 1).NumberFormat = "#,##0.00"
        .[A2].Resize(d1.Count + 1, d2.Count + 2).Borders.ColorIndex = 16
        .[A2:N2].BorderAround Weight:=xlMedium
        .[A2].Resize(d1.Count + 1).BorderAround Weight:=xlMedium
        .[N2].Resize(d1.Count + 1).BorderAround Weight:=xlMedium
        .[B3].Resize(d1.Count, d2.Count).BorderAround Weight:=xlMedium
        For i = 1 To d1.Count
            .Cells(i + 2, d2.Count + 2) = Application.Sum(Application.Index(b, i))
        Next i
        .Select
    End With
    Application.ScreenUpdating = True
MsgBox "Bitti."
End Sub

 

[ZuCChiNi]

Çok teşekkür ederim.

 

[Ziynettin]

Rica ederim.
İyi çalışmalar..