Voilà ma proposition :
Sub RetrouverMotsComplets()
Dim i As Long, j As Integer, k As Integer, Tablo(), MotsRef(), TextDecoup() As String
MotsRef() = Sheets(2).Range("A2:A" & Sheets(2).Range("A" & Rows.Count).End(xlUp).Row).Value 'Affecte les extraits à retrouver dans une variable tableau
With Sheets(1) 'Toute instruction commençant par "." se rattache à la 1ère feuille
Tablo() = .Range("B2:B" & .Range("A" & .Rows.Count).End(xlUp).Row).Value 'Affecte la plage à contrôler dans une variable tableau
For i = LBound(Tablo) To UBound(Tablo) 'Parcourir la plage à contrôler
If Not Tablo(i, 1) = "" Then
TextDecoup = Split(Tablo(i, 1), " ") 'Découper le texte mot à mot
For j = LBound(TextDecoup) To UBound(TextDecoup) 'Parcourir les mots
For k = LBound(MotsRef) To UBound(MotsRef) 'Parcourir les extraits de référence
If TextDecoup(j) Like "*" & MotsRef(k, 1) & "*" Then Sheets(2).Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Replace(Replace(TextDecoup(j), Chr(10), ""), ",", "") 'Comparer et ajouter le mot si correspondance partielle
Next k
Next j
End If
Next i
End With
Ajoutée à ton fichier :