Option Compare Text 'la casse est ignorée
Sub lister()
Dim tablo, exclu, ub&, i&, x$, j&, n&
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
exclu = [D1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
ub = UBound(exclu)
For i = 2 To UBound(tablo)
x = Replace(tablo(i, 1), " ", "") 'supprime les espaces
For j = 2 To ub
If InStr(x, exclu(j, 1)) Then GoTo 1
Next
n = n + 1
tablo(n, 1) = tablo(i, 1)
1 Next
With [F2] 'à adapter
If n Then .Resize(n) = tablo
.Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
End Sub