Sub MAJ()
Dim tablo, resu(), d As Object, i&, x$, n&, p&
tablo = Feuil1.[A2].CurrentRegion.Resize(, 6) 'matrice, plus rapide, à adapter
ReDim resu(1 To UBound(tablo), 1 To 3)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
x = tablo(i, 1)
If Not d.exists(x) Then
n = n + 1
d(x) = n 'mémorise le numéro
resu(n, 1) = x
End If
p = d(x)
resu(p, 2) = resu(p, 2) + 1
resu(p, 3) = resu(p, 3) - (tablo(i, 6) = 1)
Next
'---restitution---
Application.ScreenUpdating = False
With Feuil3 'à adapter
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
With .[A1] 'à adapter
.Cells(2).Resize(.Parent.Rows.Count - .Row, 3).Delete xlUp 'RAZ
If n Then .Cells(2).Resize(n, 3) = resu
.Resize(n + 1, 3).Sort .Cells(1, 2), xlDescending, .Cells(1, 3), , xlDescending, .Cells(1), xlAscending, Header:=xlYes 'tri
End With
With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub