Private Sub Worksheet_Change(ByVal target As Range)
Dim d As Object, tablo, i&, j%, x$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With [Tableau1] 'tableau structuré
tablo = .Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
For j = 1 To 3
x = tablo(i, j)
If x <> "" Then d(x) = d(x) + 1
Next j, i
'---restitution---
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
.AutoFilter: .AutoFilter 'si le tableau est filtré
.Columns(4) = "": .Columns(5) = "" 'RAZ
If d.Count Then
.Columns(4).Resize(d.Count) = Application.Transpose(d.keys)
.Columns(5).Resize(d.Count) = Application.Transpose(d.items)
.Columns(4).Resize(, 2).Sort .Columns(4), xlAscending, Header:=xlYes 'tri alphabétique
End If
Application.EnableEvents = True 'réactive les évènements
End With
End Sub