Sub Compter()
Dim F As Worksheet, ncol%, dest As Range, r As Range, tablo, d As Object, e
Set F = Sheets("Hoja1") 'à adapter
ncol = 3 'à adapter
Set dest = F.[E1] 'à adapter
Set r = F.UsedRange.Resize(, ncol).Offset(1) 'Offset(1) si en-têtes
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
dest(2).Resize(Rows.Count - dest.Row, 2).Delete xlUp 'RAZ
If r Is Nothing Then Exit Sub
tablo = r 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each e In tablo
If e <> "" Then d(e) = d(e) + 1
Next
'---restitution---
If d.Count = 0 Then Exit Sub
dest(2).Resize(d.Count) = Application.Transpose(d.keys) 'Transpose limitée à 65536 lignes
dest(2, 2).Resize(d.Count) = Application.Transpose(d.items)
dest(2).Resize(d.Count, 2).Interior.ColorIndex = 19 'jaune clair
dest(2).Resize(d.Count, 2).Borders.Weight = xlThin 'bordures
dest(2).Resize(d.Count, 2).Sort dest(1, 2), xlDescending, dest, , xlAscending, Header:=xlNo 'tri sur les 2 colonnes
dest.Resize(d.Count, 2).Columns.AutoFit 'ajustement largeurs
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub