Sub MAJ()
Dim coldat%, colnom%, colrest, tablo, d As Object, dd As Object, i&, x$, y$, resu()
coldat = 3 'à adapter
colnom = 6 'à adapter
colrest = 7 'à adapter
With [A1].CurrentRegion.Resize(, colrest)
tablo = .Value2 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo)
x = tablo(i, colnom): y = tablo(i, coldat) & x
If Not d.exists(x) Then d(x) = 0
If Not dd.exists(y) Then
d(x) = d(x) + 1 'comptage
dd(y) = ""
End If
Next
'---restitution---
ReDim resu(1 To UBound(tablo), 1 To 1)
resu(1, 1) = tablo(1, colrest) 'en-tête
For i = 2 To UBound(tablo)
resu(i, 1) = d(tablo(i, colnom))
Next
.Columns(colrest) = resu
End With
End Sub