Üst Üste Toplam Almak

[baydeniro]

Merhaba Arkadaşlar,

Öncelikle başta değerli üstadlarımız olmak üzere tüm excel.web.tr camiasının 2019 yılını kutlar, sağlıkla geçmesini dilerim. Karmaşık bir sorunum var.

E SÜTUNU için
DATA sayfasında C sütunundaki verilerin bu sayfanın D sütunundakilere eşit olması durumunda DATA!H:H +
DATA sayfasında J sütunundaki verilerin bu sayfanın D sütunundakilere eşit olması durumunda DATA!I:I

F SÜTUNU için
DATA sayfasında C sütunundaki verilerin bu sayfanın D sütunundakilere eşit olması durumunda DATA!I:I +
DATA sayfasında J sütunundaki verilerin bu sayfanın C sütunundakilere eşit olması durumunda DATA!H:H

Aslında bu işlemi ETOPLA ile yapabiliyoruz. Ama eğer mümkünse makro ile olmasını tercih ederim.
Örnek formül : =ETOPLA(DATA!$C$10:$C$15;TOPLAM!$D10;DATA!$H$10:$H$15)+ETOPLA(DATA!$J$10:$J$15;TOPLAM!$D10;DATA!$I$10:$I$15)

Örnek dosya linki : http://s7.dosya.tc/server12/7zjf9g/UST_USTE_TOPLA.xls.html

 

[Ziynettin]

Merhaba,

Dosya İndir

 

[baydeniro]

Ziynettin üstadım çok çok teşekkür ediyorum. Muhteşem bir kod. elleriniz dert görmesin. Kod mükemmel ve çok hızlı çalıştı.
Yalnız şöyle bir durum oldu. Kodu kendi çalışma dosyama adapte ettiğimde ise aynı sayfa yapısı ve aynı sayfa isimleri oluğu halde kod çalışma hatası verdi. RUN-TIME ERROR "13" TYPE MISMATCH

Tools > Referances bölümündeki tüm referanslar aynı. Sizce dorun ne olabilir ?

 

[baydeniro]

Üstad hiç zamanını harcama sorunu çözdüm. Diğer dosyamda başlık satırı 1 satır aşağıda olduğu için çalışmamış kod.
çok teşekkür eder, hayırlı akşamlar dilerim. Sağlıcakla kalın

 

[baydeniro]

Sayın Ziynettin üstadın yazdığı aşağıda bulunan kod mükemmel çalışıyor. Bu koda tarihi aralığı ve Mağaza filtrelemesi eklenmesi mümkün müdür acaba ?

TOPLAM sayfasında
İşyeri >> E6 hücresinde = Mağaza (İşyeri DATA sayfası E sütununda)
(İşyeri olarak TÜMÜ belirtilmişse bütün işyeri kayıtlarını dikkate alan)
İlk Tarih >> F6 hücresinde = 01.05.2018 ile (tarihler DATA sayfası D sütununda)
Son Tarih >> G6 hücresinde = 10.05.2018 arasında olan (tarihler DATA sayfası D sütununda)

Sub test()
Set s1 = Sheets("DATA")
Set s2 = Sheets("TOPLAM")
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dic3 = CreateObject("scripting.dictionary")
Set dic4 = CreateObject("scripting.dictionary")
a = s1.Range("C10:J" & s1.Cells(Rows.Count, 3).End(3).Row).Value
For i = 1 To UBound(a)
dic1(a(i, 1)) = dic1(a(i, 1)) + CDbl(a(i, 6))
dic2(a(i, 8)) = dic2(a(i, 8)) + a(i, 7)
dic3(a(i, 1)) = dic3(a(i, 1)) + CDbl(a(i, 7))
dic4(a(i, 8)) = dic4(a(i, 8)) + a(i, 6)
Next i
b = s2.Range("D10" & s2.Cells(Rows.Count, 4).End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 4)
For i = 1 To UBound(b)
urun = b(i, 1)
c(i, 1) = dic1(urun) + dic2(urun)
c(i, 2) = dic3(urun) + dic4(urun)
If c(i, 1) > c(i, 2) Then c(i, 3) = c(i, 1) - c(i, 2) Else c(i, 3) = 0
If c(i, 1) < c(i, 2) Then c(i, 4) = c(i, 2) - c(i, 1) Else c(i, 4) = 0
t1 = t1 + c(i, 1)
t2 = t2 + c(i, 2)
t3 = t3 + c(i, 3)
t4 = t4 + c(i, 4)
Next i
s2.Range("E10:H" & Rows.Count).ClearContents
s2.[E10].Resize(UBound(b), 4) = c
s2.Range("E" & 10 + UBound(b) + 1).Resize(, 4) = Array(t1, t2, t3, t4)
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[Ziynettin]

Deneme yapılmadı.

Sub test()
Dim trh_1 As Date, trh_2 As Date, mgz As String
Set s1 = Sheets("DATA")
Set s2 = Sheets("TOPLAM")
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dic3 = CreateObject("scripting.dictionary")
Set dic4 = CreateObject("scripting.dictionary")
trh_1 = s2.[F6]
trh_2 = s2.[G6]
mgz = s2.[E6]
a = s1.Range("C10:J" & s1.Cells(Rows.Count, 3).End(3).Row).Value
    For i = 1 To UBound(a)
        If mgz = "" Or mgz = "TÜMÜ" Then GoTo atla
        If a(i, 3) = mgz Then
atla:
            If a(i, 2) >= trh_1 And a(i, 2) <= trh_2 Then
                dic1(a(i, 1)) = dic1(a(i, 1)) + CDbl(a(i, 6))
                dic2(a(i, 8)) = dic2(a(i, 8)) + a(i, 7)
                dic3(a(i, 1)) = dic3(a(i, 1)) + CDbl(a(i, 7))
                dic4(a(i, 8)) = dic4(a(i, 8)) + a(i, 6)
            End If
        End If
    Next i
b = s2.Range("D10:D" & s2.Cells(Rows.Count, 4).End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 4)
    For i = 1 To UBound(b)
        urun = b(i, 1)
        c(i, 1) = dic1(urun) + dic2(urun)
        c(i, 2) = dic3(urun) + dic4(urun)
        If c(i, 1) > c(i, 2) Then c(i, 3) = c(i, 1) - c(i, 2) Else c(i, 3) = 0
        If c(i, 1) < c(i, 2) Then c(i, 4) = c(i, 2) - c(i, 1) Else c(i, 4) = 0
        t1 = t1 + c(i, 1)
        t2 = t2 + c(i, 2)
        t3 = t3 + c(i, 3)
        t4 = t4 + c(i, 4)
    Next i
s2.Range("E10:H" & Rows.Count).ClearContents
s2.[E10].Resize(UBound(b), 4) = c
s2.Range("E" & 10 + UBound(b) + 1).Resize(, 4) = Array(t1, t2, t3, t4)
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[baydeniro]

Ziynettin üstadım, kod tek kelime ile "MUHTEŞEM" elinize emeğinize aklınıza sağlık, elleriniz dert görmesin. Sağlıcakla kalın.