Rechercher plusieurs mots dans une ligne : RecherchV/Vlookup/SI ?

Sub Extract()
    Dim DerLig_Liste As Long, DerLig_Chaine As Long, i As Long, j As Long, NbCar As Long
    Dim Res As Variant, Texte As Variant
    Application.ScreenUpdating = False
    DerLig_Liste = Range("G" & Rows.Count).End(xlUp).Row
    DerLig_Chaine = Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To DerLig_Chaine
        Res = ""
        Texte = ""
        Chaine = Cells(i, "A")
        For j = 2 To DerLig_Liste
            NbCar = Len(Cells(j, "G"))
            On Error Resume Next
            Texte = Mid(Chaine, InStr(1, Chaine, Cells(j, "G"), 1), NbCar)
            If Err.Number = 0 Then
                Res = Res & ", " & Texte
            End If
            On Error GoTo 0
        Next j
        Cells(i, "B") = Mid(Res, 3, Len(Res) - 2)
    Next i
End Sub

Option Explicit
Function ExtraireTextesPhrase(textes As Range, phrase As Range) As Variant
Dim t, p$, i&, r$
  If phrase.Count <> 1 Then ExtraireTextesPhrase = CVErr(XlCVError.xlErrRef): Exit Function  '#REF!
  ReDim t(1 To 1, 1 To 1)   'Pour le cas où "textes" ne représente qu'une seule cellule
  If textes.Count = 1 Then t(1, 1) = textes.Value Else t = textes.Value
  For i = 1 To UBound(t)
    If TypeName(t(i, 1)) = "String" Then
      If t(i, 1) <> "" And InStr(1, LCase(phrase), LCase(t(i, 1))) > 0 Then
        r = r & ", " & t(i, 1)
      End If
    End If
  Next i
  ExtraireTextesPhrase = Mid(r, 3)
End Function