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
Dim nextcell As Range, assupprimer As Range, q, q2
With Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:B")): .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
Set assupprimer = plage.Cells(plage.Cells.Count, 1)
Application.ScreenUpdating = False
With Sheets("liste"): Set listemot = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)): End With
t = Timer
q = listemot.Cells.Count
For Each cel1 In listemot.Cells
mot = Trim(cel1.Value)
q2 = q2 + 1
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
i = i + Len(mot)
End If
Next
End If
If Not IsNull(cel.Font.Color) And q2 = q Then Set assupprimer = Union(assupprimer, cel)
Next cel
Next cel1
'MsgBox assupprimer.Address
assupprimer.EntireRow.Delete xlShiftUp
MsgBox Format(Timer - t, "00.00 \sec") & vbCrLf
End Sub