Sub Test1()
Dim Dict, T1, i
Set Dict = CreateObject("scripting.dictionary")
Dict.CompareMode = vbTextCompare
T1 = Range("Tableau1").Value2 'lire le tableau
For i = 1 To UBound(T1)
Dict(T1(i, 2)) = Dict(T1(i, 2)) + T1(i, 3) 'cumuler l'item
Next
With Range("G7")
.Resize(100, 2).ClearContents 'on efface les anciens résultats
If Dict.Count Then
With .Resize(Dict.Count)
.Value = Application.Transpose(Dict.Keys) 'clé
.Offset(, 1).Value = Application.Transpose(Dict.Items) 'item
.Resize(, 2).Sort .Range("B2"), xlDescending, Header:=xlNo 'trier
End With
End If
End With
End Sub