Autres Macro qui supprime des lignes si une cellule vide

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

Private Sub Worksheet_Activate()
With Sheets("Données brutes").UsedRange.EntireRow
    .AutoFilter
    .AutoFilter 40, "*Balai*", xlOr, "*Taxi*"
    .Copy [A1] 'copier-coller
    .AutoFilter 'ôte le filtre
End With
End Sub

Sub Filtrer()
Dim dercel As Range
Set dercel = Cells.SpecialCells(xlCellTypeLastCell)
Application.ScreenUpdating = False
With Range(Cells(2, dercel.Column + 1), dercel(1, 2))
    If .Row = 1 Then Exit Sub
    .Formula = "=SIGN(IFERROR(SEARCH(""Taxi"",AN2),SEARCH(""Balai"",AN2)))"
    .Value = .Value 'supprime les formules
    .EntireRow.Sort .Cells, xlAscending, Header:=xlNo 'tri pour regrouper et accélérer
    On Error Resume Next
    .SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete 'supprime les valeurs d'erreur
    .ClearContents 'RAZ
End With
End Sub