Private Sub Worksheet_Activate()
Dim t, ncol%, d1 As Object, d2 As Object, i&, j%, nom$, a, b, c
t = Feuil1.[A1].CurrentRegion 'CodeName de la feuille
ncol = UBound(t, 2)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
For j = 4 To ncol
nom = t(i, j)
If nom <> "" Then
d1(nom) = d1(nom) + t(i, 3)
d2(nom) = d2(nom) + 1
End If
Next
Next
If d1.Count Then
'---transposition---
ReDim t(d1.Count - 1, 2) 'base 0
a = d1.keys: b = d1.items: c = d2.items
For i = 0 To d1.Count - 1
t(i, 0) = a(i): t(i, 1) = b(i): t(i, 2) = c(i)
Next
'---restitution et tri---
Application.ScreenUpdating = False
With [A2].Resize(i, 3)
.Value = t
.Borders.Weight = xlThin 'bordures
.Sort .Columns(1), xlAscending, Header:=xlNo
End With
End If
Range("A" & d1.Count + 2 & ":C" & Rows.Count).Delete xlUp
End Sub