Sub Comptage()
Dim dest As Range, t, d1 As Object, d2 As Object, d3 As Object
Dim d4 As Object, i&, x$, a, b, c, d
Set dest = [G8] 'à adapter
t = [A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Set d4 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
If t(i, 1) <> "" And t(i, 4) <> 0 Then 'And UCase(t(i, 5)) = "OUI" ?
x = LCase(t(i, 1)) & t(i, 3) 'nom + année
d1(x) = t(i, 3): d2(x) = t(i, 1)
d3(x) = d3(x) + t(i, 4): d4(x) = d4(x) + 1
End If
Next
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1, 4).ClearContents 'RAZ
If d1.Count Then
a = d1.items: b = d2.items: c = d3.items: d = d4.items
ReDim t(UBound(a), 3) 'base 0
'---transposition---
For i = 0 To UBound(a)
t(i, 0) = a(i): t(i, 1) = b(i): t(i, 2) = c(i): t(i, 3) = d(i)
Next
'---restitution---
dest.Resize(d1.Count, 4) = t
dest.Resize(d1.Count, 4).Sort dest, xlAscending, dest(1, 2), , xlAscending, Header:=xlNo 'tri
End If
End Sub