Sub Recherche()
Dim s, d As Object, i&, a, ub%, tablo, x$, flag As Boolean, j%, n&
'---liste recherchée sans doublon---
s = Split([E2]) 'cellule à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 0 To UBound(s)
If s(i) <> "" Then d(s(i)) = " " & LCase(s(i)) & " "
Next
'---analyse---
If d.Count Then
a = d.items: ub = UBound(a)
tablo = [B1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
x = " " & LCase(Application.Trim(tablo(i, 1))) & " "
flag = True
For j = 0 To ub
If InStr(x, a(j)) = 0 Then flag = False: Exit For
Next j
If flag Then n = n + 1: tablo(n, 1) = tablo(i, 1): tablo(n, 2) = i
Next i
End If
'---restitution---
With Feuil1 'CodeName
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
With .[E5] 'cellule de restitution, à adapter
If n Then
.Resize(n, 2) = tablo
.Resize(n, 2).Interior.Color = [E2].Interior.Color
.Resize(n, 2).Borders.Weight = xlHairline 'bordures
End If
.Offset(n).Resize(.Parent.Rows.Count - n - .Row + 1, 2).Delete xlUp 'RAZ en dessous
End With
With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
