Private Sub Worksheet_Activate()
Dim t, d As Object, i&, a, b
t = Feuil1.[A1].CurrentRegion.Resize(, 3)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
For i = 2 To UBound(t)
d(t(i, 2)) = d(t(i, 2)) + IIf(IsNumeric(t(i, 3)), t(i, 3), 0)
Next
If FilterMode Then ShowAllData 'si la feuille est filtrée
Range("A2:B" & Rows.Count) = "" 'RAZ
If d.Count = 0 Then Exit Sub
a = d.keys: b = d.items: ReDim t(UBound(a), 1) 'base 0
For i = 0 To UBound(a)
t(i, 0) = a(i): t(i, 1) = b(i)
Next
[A2].Resize(i, 2) = t
[A2].Resize(i, 2).Sort [A2], xlAscending, Header:=xlNo 'tri facultatif
End Sub