Private Sub CommandButton2_Click()
Dim i&, cel1 As Range, cel As Range, couleur&, phrase$, mot$, plage As Range, listemot As Range, t, x As Boolean, y As Boolean
With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:A")): .Clear: End With 'clear feuil3
Intersect(Sheets(1).UsedRange, Sheets(1).Range("A:A")).Copy [A1] 'copy feuil1 to feuil3
With ActiveSheet: Set plage = Intersect(.UsedRange, .Range("A:A")): End With
Application.ScreenUpdating = False
With Sheets("liste"): Set listemot = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)): End With
t = Timer
For Each cel1 In listemot.Cells
mot = Trim(cel1.Value)
For Each cel In plage.Cells
If mot <> "" Then
phrase = " " & cel.Value & " "
For i = 2 To Len(phrase)
If Mid(phrase, i, Len(mot)) = mot Then
x = UCase(Mid(phrase, i - 1, 1)) = LCase(Mid(phrase, i - 1, 1)) And Not IsNumeric(Mid(phrase, i - 1, 1))
y = UCase(Mid(phrase, i + Len(mot), 1)) = LCase(Mid(phrase, i + Len(mot), 1)) And Not IsNumeric(Mid(phrase, i + Len(mot), 1))
If x And y Then
With cel.Characters(i - 1, Len(mot))
.Font.Color = cel1.Font.Color
.Font.Italic = cel1.Font.Italic
.Font.Bold = cel1.Font.Bold
End With
End If
End If
Next
End If
Next cel
Next cel1
MsgBox Format(Timer - t, "00.00 \sec")
End Sub