Private Sub Worksheet_Change(ByVal Target As Range)
Dim source As Range, dest As Range, sep$, d As Object, t, i&, s, j%, x$
Set source = [A3] '1ère cellule de la liste source, à adapter
Set dest = [C4] '1ère cellule de destination, à adapter
sep = ";" 'séparateur, à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If Me.FilterMode Then Me.ShowAllData 'si la feuille est filtrée
dest.Resize(Rows.Count - dest.Row + 1, 2) = "" 'RAZ
'---analyse de la liste sans doublon---
With Range(source, Cells(Rows.Count, source.Column).End(xlUp))
If .Row >= source.Row Then
t = .Resize(, 2) 'au moins 2 éléments
For i = 1 To UBound(t)
s = Split(CStr(t(i, 1)), sep)
For j = 0 To UBound(s)
x = Trim(s(j))
d(x) = d(x) + 1 'comptage
Next j, i
End If
End With
'---restitution---
If d.Count Then
dest.Resize(d.Count) = Application.Transpose(d.keys) 'maximum 65536 lignes
dest(1, 2).Resize(d.Count) = Application.Transpose(d.items)
dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo 'tri alphabétique
End If
Application.EnableEvents = True 'réactive les évènements
End Sub