Sub MiseCouleurTexte(Mot1, Pos1, Col)
Dim Texte$
Dim j%, i%, P&, Nb%, Nb1%, K%
Dim Terme(), Terme2$
Sheets("Feuil2").Activate
Application.ScreenUpdating = False
'----- dernière ligne de la plage ---------
Nb = Sheets("Feuil2").Cells(65536, Col).End(xlUp).Row
'-------------------------
'MsgBox "Nb= " & Nb & " Pos1= " & Pos1 & " Mot1= " & Mot1
If Mot1 = "" Then Exit Sub
Terme = Array("", "", ".", ",")
'-------- Traitement -------
For j = 1 To 3
Terme2 = Mot1 & Terme(j) & " "
For i = Pos1 To Nb + 1
Texte = Cells(i, Col).Value
Nb1 = Len(Texte)
For K = 1 To Nb1
P = InStr(K, Texte & " ", Terme2, 1)
' If P <> 0 Then MsgBox "P= " & P & " Nb1= " & Nb1 & " terme2= " & Terme2
If P > 0 Then Cells(i, Col).Characters(Start:=P, Length:=Len(Terme(j) & Mot1)).Font.Color = RGB(255, 0, 0)
If P > 0 Then Cells(i, Col).Characters(Start:=P, Length:=Len(Terme(j) & Mot1)).Font.Bold = True
Next K
Next i
Next j
Application.ScreenUpdating = True
End Sub