Slet rækker hurtigere

Hej jeg har en makro som sletter rækker i et ark og den virker sådan set som den skal. Jeg har dog et problem, jeg synes den er for langsom. Den bruger ca. 2 min  på at køre makroen igennem på arket. Problemet opstår da den skal køre denne makro på 106 ark (2*106=212min) Det vil sige man min computer er ude af brug i 3,5 time

Koden ser sådan her ud for at slette rækkerne:

Sub DelRow()

Sheets("enhed 6").Select

For Each c In Range("Q1:Q6054")
If Not IsEmpty(c) And c.Value = 0 Then c.Value = True
Next
Range("Q1:Q6054").SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete

Columns("Q:Q").Select
    Selection.Delete shift:=xlToLeft
    Range("A1").Select
   
   
End Sub

Håber der er nogen som har et forslag til hvordan jeg gør denne proces hurtigere :)