Sub Total()
Dim dest As Range, nlig&, ncol%, tablo, resu, d As Object, i&, n&, j%, d1 As Object, x$, y&
Application.ScreenUpdating = True
Set dest = [F1] '1ère cellule de destination, à adapter
With [A1].CurrentRegion
If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
nlig = .Rows.Count
ncol = .Columns.Count
dest(2).Resize(.Parent.Rows.Count - dest.Row, ncol).ClearContents 'RAZ
tablo = .Resize(nlig + 1) 'matrice, plus rapide, au moins 2 éléments
End With
ReDim resu(1 To nlig, 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To nlig
If Not d.exists(tablo(i, 1)) Then
n = n + 1
resu(n, 1) = tablo(i, 1)
d(tablo(i, 1)) = n 'mémorisation de la ligne
End If
Next i
If d.Count = 0 Then Exit Sub
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = vbTextCompare 'la casse est ignorée
For j = 2 To ncol
d1.RemoveAll
For i = 2 To nlig
x = tablo(i, 1) & Chr(1) & Trim(tablo(i, j))
If Not d1.exists(x) Then
d1(x) = ""
y = d(tablo(i, 1))
resu(y, j) = resu(y, j) + 1
End If
Next i, j
dest(2).Resize(n, ncol) = resu
End Sub