Option Explicit
Sub FindWords()
Dim Wd As New Collection, VA, LRowB As Integer, V, x As Long, y As Integer, L As String, T!
T = Timer
VA = ActiveSheet.Cells(1).CurrentRegion.Value
LRowB = Application.CountA(ActiveSheet.Cells(1).CurrentRegion.Offset(, 1).Resize(, 1))
For x = 2 To UBound(VA)
V = Split(Application.Trim(VA(x, 1)))
L = "CLIENT "
For y = LBound(V) To UBound(V)
On Error Resume Next
Wd.Add L, V(y)
If Err Then Err.Clear
Next
Next
For x = 2 To LRowB
V = Split(Application.Trim(VA(x, 2)))
L = ""
For y = LBound(V) To UBound(V)
On Error Resume Next
L = Wd(V(y)) & "OK"
If Err Then Err.Clear
Next
If Len(L) = 0 Then L = "RISQUE DE CONFLIT - CLIENT NOK"
VA(x, 3) = L
Next
VA = Application.Index(VA, Application.Evaluate("Row(" & 2 & ":" & LRowB & ")"), 3)
Application.ScreenUpdating = False
ActiveSheet.Cells(2, 3).Resize(UBound(VA), 1).Value = VA
Application.ScreenUpdating = True
MsgBox Format(Timer - T, "0.0000s")
End Sub