Détecter un mot dans chaque ligne de cellule.

Sub essai()
  Application.ScreenUpdating = False
  Set d = CreateObject("scripting.dictionary")
  For Each c In [ListeMots]
    d(c.Value) = ""
  Next c
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  Rng.Offset(, 1).ClearContents
  Tbl = Rng.Value
  For i = 1 To UBound(Tbl)
      a = Split(Tbl(i, 1), " ")
      témoin = False
      For Each k In a
        If d.exists(k) Then témoin = True
      Next k
      If témoin Then Rng.Offset(, 1).Cells(i, 1) = "X"
  Next i
End Sub

Sub motclé_sd2()
  '-- fait par jb
  T = Timer()
  Application.ScreenUpdating = False
  Set D = CreateObject("scripting.dictionary")
  '--tableau non nommé / version jb
  derl = Cells(Rows.Count, 5).End(3).Row
  For Each C In Range("E2:E" & derl)
    D(LCase(C.Value)) = "" '-- prise en compte lower case
  Next C
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  Rng.Offset(, 2).ClearContents
  Tbl = Rng.Value
  For i = 1 To UBound(Tbl)
      A = Split(Tbl(i, 1), " ")
      témoin = False
      For Each k In A
         If Len(k) >= 2 Then
         k2 = Mid(k, 1, Len(k) - 1)  '-- contournement pluriel et féminin
         If D.exists(LCase(k)) Then témoin = True
         If D.exists(LCase(k2)) Then témoin = True
         End If
        Next k
      If témoin Then Rng.Offset(, 2).Cells(i, 1) = "X"
  Next i
  MsgBox Timer - T
End Sub

Sub Traiter()
Dim txt$, tablo, i&, s, x$, y$, j%
txt = "Badminton" 'à adapter
With [A1].CurrentRegion.Resize(, 3)
    tablo = .Value 'matrice, plus rapide
    For i = 2 To UBound(tablo)
        s = Split(tablo(i, 1), vbLf)
        x = "": y = ""
        For j = 0 To UBound(s)
            If InStr(s(j), txt) Then x = x & vbLf & s(j) Else y = y & vbLf & s(j)
        Next j
        tablo(i, 2) = IIf(x = "", "", Mid(x, 2))
        tablo(i, 3) = IIf(y = "", "", Mid(y, 2))
    Next i
    .Value = tablo 'restitution
End With
End Sub

Sub shextract_2mc()
'-- extraction avec 2 mots recherchés
derligne = Cells(Rows.Count, 1).End(3).Row
For i = 2 To derligne
liste = "Badminton,foot" '--E1
x1 = Split(Cells(i, 1), Chr(10))
y = ""
Z = ""
For t = 0 To UBound(x1)
x = Split(x1(t), " ")
    For k = 0 To UBound(x)
        If InStr("," & liste & ",", "," & x(k) & ",") > 0 Then '--E2
        y = y + x1(t) + Chr(10)
        GoTo prochain
        Else
        End If
        Next k
Z = Z + x1(t) + Chr(10)
prochain:
Next t
Cells(i, 2) = Left(y, Len(y) - 1)
Cells(i, 3) = Left(Z, Len(Z) - 1)
Next i
End Sub

If s(j) <> "" Then If InStr(s(j), txt) Then x = x & vbLf & s(j) Else y = y & vbLf & s(j)