Sub ConserverLignes()
Dim xrg As Range, t, i&, s, dercol&, debut
debut = Timer
Set xrg = Intersect(Columns("an:an"), Me.UsedRange, Rows(2).Resize(Rows.Count - 1))
t = xrg
For i = 1 To UBound(t)
s = ";" & LCase(Replace(t(i, 1), " ", "")) & ";"
If s Like "*;balai;*" Then
t(i, 1) = i
ElseIf s Like "*;taxi;*" Then
t(i, 1) = i
Else
t(i, 1) = Empty
End If
Next i
dercol = Me.UsedRange.Column + Me.UsedRange.Columns.Count
Application.ScreenUpdating = False
Cells(xrg.Row, dercol).Resize(UBound(t)) = t
With Rows(xrg.Row).Resize(UBound(t), dercol)
.Sort Key1:=.Cells(1, dercol), order1:=xlAscending, Header:=xlNo
On Error Resume Next
.Columns(dercol).SpecialCells(xlCellTypeBlanks).Select
.Columns(dercol).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns(dercol).Delete
End With
MsgBox Format(UBound(t), "#,##0") & " lignes traitées en " & Format(Timer - debut, "0.00\ sec,") & _
vbLf & vbLf & "il reste " & Format(Application.CountA(Columns("an:an")) - 1, "#,##0\ lignes."), vbInformation
End Sub