Sub MotsDansPhrase()
Dim dicoMots, dicoPhrases, derMot&, derPhrase&
Dim tablo, tailMin&, tailmax, aux
Dim elem, i&, t0, Nelem&
' effacement des précédents résultats
Range("b2:b" & Rows.Count).ClearContents
t0 = Timer
' remplissage de dicoMots
derMot& = Range("c" & Rows.Count).End(xlUp).Row
tablo = Range("c2:c" & derMot&).Value
Set dicoMots = CreateObject("scripting.dictionary")
dicoMots.CompareMode = vbTextCompare 'vbBinaryCompare
tailMin = 99999
For Each elem In tablo
' ajouter au dico
dicoMots(CStr(elem)) = Empty
' Longueur Max et min des éléments de la liste des mots à chercher
If Len(elem) < tailMin Then tailMin = Len(elem)
If Len(elem) > tailmax Then tailmax = Len(elem)
Next elem
' boucle sur chaque phrase
derPhrase = Range("a" & Rows.Count).End(xlUp).Row
tablo = Range("a2:a" & derPhrase).Value
For i = 1 To derPhrase - 1
' remplissage de dicoPhrases
sousListe tablo(i, 1), tailMin, tailmax, aux, Nelem
tablo(i, 1) = Empty
If Nelem > 0 Then
Set dicoPhrases = CreateObject("scripting.dictionary")
dicoPhrases.CompareMode = vbTextCompare 'vbBinaryCompare
For Each elem In aux: dicoPhrases(elem) = Empty: Next elem
' boucle de recherche
For Each elem In dicoPhrases
If dicoMots.Exists(elem) Then
tablo(i, 1) = elem
Exit For
End If
Next elem
End If
Next i
Range("b2").Resize(derPhrase - 1) = tablo
MsgBox "Terminé -> " & Format(Timer - t0, " #,##0") & " sec."
End Sub
Sub sousListe(X, xmin, xmax, yRes, yN)
' découpe la phrase en autant de string de longueur L que possible
' L parcourt l'intervalle xmin à bsup (qui est le max de len(X) et de xmax)
' on renvoie un tableau yRes avec tous ces string
' on renvoie aussi yN qui est le nombre de string
Dim tablo(), i&, j&, m&, ncar&, bsup&
ncar = Len(X)
If xmax <= Len(X) Then bsup = xmax Else bsup = Len(X)
For i = xmin To bsup
For j = 1 To ncar - i + 1
m = m + 1
ReDim Preserve tablo(1 To m)
tablo(m) = Mid(X, j, i)
Next j
Next i
yRes = tablo: yN = m
End Sub