Private Sub Worksheet_Change(ByVal Target As Range)
Dim dest As Range, t, d As Object, i&, a, b, c
Set dest = [H10] 'cellule de destination, à adapter
On Error Resume Next
t = Intersect(Range("A7:F" & Rows.Count), Me.UsedRange) 'à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(t)
If Not IsNumeric(t(i, 4)) Then t(i, 4) = 0
d(t(i, 2)) = d(t(i, 2)) + t(i, 4)
Next
'---transposition---
a = d.keys: b = d.items
ReDim c(UBound(a), 1) 'base 0
For i = 0 To UBound(c)
c(i, 0) = a(i): c(i, 1) = b(i)
Next
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False
dest.Resize(d.Count, 2) = c
dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo 'tri
dest.Offset(d.Count).Resize(Rows.Count - d.Count - dest.Row + 1, 2).ClearContents
Application.EnableEvents = True
End Sub