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