Bonjour,
voici un exemple,
Sub colore()
Dim keywords As String, firstAddress As String, c As Range, i As Long
For i = 2 To Sheets("Liste").Cells(Rows.Count, 1).End(xlUp).Row
keywords = Sheets("Liste").Cells(i, 1) 'mot rechercher
With ActiveSheet.Range("Q:Q") 'plage de recherche
Set c = .Find(keywords, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
For j = 1 To Len(c)
If LCase(Mid(c, j, Len(keywords))) = LCase(keywords) Then 'compare en minuscule
With c.Characters(j, Len(keywords)).Font
.ColorIndex = 3
.Bold = True
.Underline = True
End With
End If
Next
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Next i
End Sub