Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:C,G1]) Is Nothing Then Exit Sub
Dim an%, tablo, resu(), d1 As Object, d2 As Object, i&, x$, n&, y$
an = [G1]
tablo = [A1].CurrentRegion.Resize(, 3) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 2)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
d1.CompareMode = vbTextCompare 'la casse est ignorée
d2.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo)
If tablo(i, 3) = an Then
x = tablo(i, 1)
If Not d1.exists(x) Then
n = n + 1
d1(x) = n 'mémorise la ligne
resu(n, 1) = x
End If
y = x & Chr(1) & tablo(i, 2)
If Not d2.exists(y) Then
d2(y) = ""
resu(d1(x), 2) = resu(d1(x), 2) + 1
End If
End If
Next
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [I2] 'cellule à adapter
If n Then .Resize(n, 2) = resu
.Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
End Sub