Private Sub Worksheet_Activate()
Dim mini%, d As Object, tablo, i&, x$, j%, maxi%, resu$(), n&
mini = 32767
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Sheets("Listes")
tablo = .[C1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
x = tablo(i, 1)
d(x) = ""
j = Len(x)
If j > maxi Then maxi = j
If j < mini Then mini = j
Next i
tablo = .[A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(tablo), 1 To 1)
For i = 2 To UBound(tablo)
x = tablo(i, 1)
For j = mini To maxi
If d.exists(Right(x, j)) Then n = n + 1: resu(n, 1) = x
Next j, i
End With
'---restitution---
If FilterMode Then ShowAllData
With [A2] '1ère cellule de destination, à adapter
If n Then .Resize(n) = resu
.Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents
End With
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub