Verwijderen van duplicaten en het optellen van de rij er naast

[KWouters]

Hallo,

Ik heb de volgende excelsheet:


Ik ben op zoek naar een macro die de volgende resultaten weergeeft:


De bedoeling is dus dat de macro de duplicaten in kolom B verwijdert en de waardes in kolom A optelt.

Mvg,

Koen

 

[Ginger]

Koppel een draaitabel (Pivot Table) aan je gegevenslijst. Die doet dat dan automatisch voor je....

 

[KWouters]

Bedankt voor de reactie.
De sheet gaat uiteindelijk dienen als template daarom wil ik er geen pivot van maken. De opmaak van een Pivot kun je niet zo mooi maken en ik wil met 1 druk op de knop het bovenstaande kunnen realiseren.

 

[HSV]

@Joost, dit is al voldoende om de draaitabel te verversen.

ThisWorkbook.RefreshAll

 

[Warme bakkertje]

Sub tst()
    sn = Sheets("Blad1").ListObjects(1).DataBodyRange.Value
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(sn)
            If Not .exists(Join(Array(sn(i, 2), sn(i, 3)), "_")) Then
                .Add Join(Array(sn(i, 2), sn(i, 3)), "_"), sn(i, 1)
            Else
                .Item(Join(Array(sn(i, 2), sn(i, 3)), "_")) = .Item(Join(Array(sn(i, 2), sn(i, 3)), "_")) + sn(i, 1)
            End If
        Next
        a = Application.Transpose(Array(.items, .keys))
    End With
    Range("E1").Resize(UBound(a, 1), 2) = a
    Range("F1:F" & Cells(Rows.Count, 6).End(xlUp).Row).TextToColumns , , , , 0, 0, 0, 0, -1, "_"
End Sub