Tekrarlayanları Toplayarak Teke İndirmek

[baydeniro]

Merhaba Arkadaşlar,

B:C sütunlarındaki verilerden yinelenenleri kaldırıp kendi içlerindeki toplamları hesaplamak mümkün olabilir mi ?

Örnek dosya link adresi : https://yadi.sk/i/IGLsjU_p_q2cVw

 

[Ziynettin]

Sub Topla()
a = Range("B4:C" & Cells(Rows.Count, 2).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a) + 2, 1 To 2)
    For i = 1 To UBound(a)
        If d.exists(a(i, 1)) Then
            sat = d(a(i, 1))
        Else
            d(a(i, 1)) = d.Count + 1
            sat = d.Count
            b(sat, 1) = a(i, 1)
        End If
        b(sat, 2) = b(sat, 2) + CDbl(a(i, 2))
        toplam = toplam + a(i, 2)
    Next i
    b(d.Count + 2, 2) = toplam
Range("B4:C" & Rows.Count) = ""
[B4].Resize(d.Count + 2, 2) = b
End Sub

 

[baydeniro]

Ziynettin üstadım çok teşekkür ederimi ellerin dert görmesin. çok çok harika oldu. Sağlıcakla kalın

 

[Mdemir63]

Selamlar
F4 Hücresine kopyalayıp aşağı doğru çekiniz.

=ETOPLA($B$4:$B$13;E4;$C$4:$C$13)

 

[baydeniro]

Mdemir63 desteğiniz için çok teşekkür ederim. Sağlıcakla kalın

 

[Korhan Ayhan]

Alternatif olarak Özet Tablo deneyebilirsiniz.