Sub Compte()
Dim T(), DL%, L1%, L2%, Qté%, Nom$
Application.ScreenUpdating = False
' Taille tableau
DL = Range("A65500").End(xlUp).Row
' Tranfert dans array, plus raide
T = Range("B3:C" & DL)
' Cumul des quantités
For L1 = 1 To UBound(T)
Nom = T(L1, 1)
Qté = 0
For L2 = L1 To UBound(T)
If T(L2, 1) = Nom Then Qté = Qté + T(L2, 2)
Next L2
T(L1, 2) = Qté
Next L1
' Tri quantités décroissante
For L1 = 1 To UBound(T)
For L2 = 1 To UBound(T)
If T(L1, 2) > T(L2, 2) Then
Nom = T(L1, 1): Qté = T(L1, 2) ' Transfert Valeur 1
T(L1, 1) = T(L2, 1): T(L1, 2) = T(L2, 2) ' Swap Valeur1 valeur2
T(L2, 1) = Nom: T(L2, 2) = Qté ' Transfert Valeur 1 dans Valeur2
End If
Next L2
Next L1
' Suppression doublons
While (T(3, 1) = T(1, 1) Or T(3, 1) = T(2, 1)) Or T(2, 1) = T(1, 1)
If T(3, 1) = T(1, 1) Or T(3, 1) = T(2, 1) Then T(3, 2) = 0
If T(2, 1) = T(1, 1) Then T(2, 2) = 0
' Tri quantités décroissante
For L1 = 1 To UBound(T)
For L2 = 1 To UBound(T)
If T(L1, 2) > T(L2, 2) Then
Nom = T(L1, 1): Qté = T(L1, 2) ' Transfert Valeur 1
T(L1, 1) = T(L2, 1): T(L1, 2) = T(L2, 2) ' Swap Valeur1 valeur2
T(L2, 1) = Nom: T(L2, 2) = Qté ' Transfert Valeur 1 dans Valeur2
End If
Next L2
Next L1
Wend
' Transfert des 3 premiers
For L = 1 To 3
Cells(5 + L, "G") = T(L, 1)
Cells(5 + L, "H") = T(L, 2)
Next L
End Sub