Çoketopla ile yeni tablo oluşturma (formüllü yada macrolu)

[mehmetsgk]

Öncelikle herkese selamlar... "Belge" isimli sayfada 2 adet tablomuz var "A TABLO" sunun yıl-ay-gün-kazanç başlıklı hücrelerine yazdığım verileri "B TABLO" suna kriterlere uygun bir şekilde toplamını yazmasını istiyorum.
1. kriter 1978/1. ayından 1982/12.ayına kadar 3 aylık dönemler olarak gün ve kazançları toplam alıcak
2. kriter 1983/1. ayından 2004/12.ayına kadar 4 aylık dönemler olarak gün ve kazançları toplam alıcak
3. Aldığı toplamları "B TABLO" sunun gün ve kazanç sütünlarına kendi aktarıcak.
4. "tablo ve kriterler" sayfasında kriterler açıkca anlatılmıştır.renkler ile toplamı ve mantığı anlatmata çalıştım.
bakalım bu zor konuyu çözebilecekmiyiz

link: https://yadi.sk/i/c-WJZ4ou3WmKJj

 

[Ziynettin]

1979 yılında 3. 4. 5. aylar var.
3. ay 1.dönem, 4 ve 5. aylar 2. dönem, buna göre 1979 yılına ait 1. dönem ve 2. dönem olarak
ayrı toplaması gerekmez mi?

Sub B_tablosu()
Sheets("belge").Select
a = Range("A8:F" & Range("A" & Rows.Count).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 6)
    For i = 1 To UBound(a)
        If a(i, 1) < 1983 Then
            If a(i, 2) <= 12 Then dönem = 4
            If a(i, 2) <= 9 Then dönem = 3
            If a(i, 2) <= 6 Then dönem = 2
            If a(i, 2) <= 3 Then dönem = 1
        End If
        If a(i, 1) >= 1983 Then
            If a(i, 2) <= 12 Then dönem = 3
            If a(i, 2) <= 8 Then dönem = 2
            If a(i, 2) <= 4 Then dönem = 1
        End If
    krt = a(i, 1) & dönem
        If Not d.exists(krt) Then
            d(krt) = d.Count + 1
            say = d.Count
            b(say, 1) = a(i, 1)
            b(say, 2) = dönem
        End If
        b(d(krt), 4) = b(d(krt), 4) + a(i, 4)
        b(d(krt), 6) = b(d(krt), 6) + a(i, 6)
    Next i
    Range("H8:M" & Rows.Count).ClearContents
    [H8].Resize(say, 6) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[mehmetsgk]

1979 yılında 3. 4. 5. aylar var.
3. ay 1.dönem, 4 ve 5. aylar 2. dönem, buna göre 1979 yılına ait 1. dönem ve 2. dönem olarak
ayrı toplaması gerekmez mi?

Sub B_tablosu()
Sheets("belge").Select
a = Range("A8:F" & Range("A" & Rows.Count).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 6)
    For i = 1 To UBound(a)
        If a(i, 1) < 1983 Then
            If a(i, 2) <= 12 Then dönem = 4
            If a(i, 2) <= 9 Then dönem = 3
            If a(i, 2) <= 6 Then dönem = 2
            If a(i, 2) <= 3 Then dönem = 1
        End If
        If a(i, 1) >= 1983 Then
            If a(i, 2) <= 12 Then dönem = 3
            If a(i, 2) <= 8 Then dönem = 2
            If a(i, 2) <= 4 Then dönem = 1
        End If
    krt = a(i, 1) & dönem
        If Not d.exists(krt) Then
            d(krt) = d.Count + 1
            say = d.Count
            b(say, 1) = a(i, 1)
            b(say, 2) = dönem
        End If
        b(d(krt), 4) = b(d(krt), 4) + a(i, 4)
        b(d(krt), 6) = b(d(krt), 6) + a(i, 6)
    Next i
    Range("H8:M" & Rows.Count).ClearContents
    [H8].Resize(say, 6) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

evet. doğru anlamışsınız kriteri fakat ben örnekte hata yapmışım. çok teşekkür ederim elinize sağlık macroyu denedim çalışıyor ama küçük bir sorun çıktı a37 a38 a39 a40 hücrelerine birşeyler yazınca macro hata uyarısı veriyor.

 

[Ziynettin]

Hata aldığınız dosyayı ekler misiniz.

 

[mehmetsgk]

Hata aldığınız dosyayı ekler misiniz.

burada hata veriyordu "b(d(krt), 6) = b(d(krt), 6) + a(i, 6)"... a37 a38 a39 a40 hücrelerine metin girilince hata veriyordu bende b sutununa kaydırdım sorun çözüldü sanırım a sutununa metin girişi macroyu etkiliyor.