Makro löscht zu langsam

Kann mir jemand helfen. Ich will nach diesen Einträgen suchen und die ganze Zeile löschen.
Leider sind es 5000 Datensätze und es dauert fast 10 min.
Dim var2 As Variant
Do While Not IsError(var2)
var2 = Application.Match("Aktion des Auto", Columns(1), 0)
If Not IsError(var2) Then Rows(var2).Select
Selection.Delete Shift:=xDown
Loop
Dies ist der Quelltext.. Kann man das noch beschleunigen ?
Andi