Possible to make this macro faster?

[ste33uka]

Hi could anyone make this macro faster for deleting rows?
The macro deletes rows if cells R to P are blank
Currently it is taking 15 minutes to do 1000 rows.
Thanks

Sub DeleteRows()
Dim x As Long, LastRow As Long, cRange As Range
LastRow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
Set cRange = Range("R1:P" & LastRow)
For x = cRange.Cells.Count To 1 Step -1
    With cRange.Cells(x)
        If Application.WorksheetFunction.CountIf(Range("p" & .Row & ":" & "r" & .Row), "") = 3 Then
            .EntireRow.Delete
        End If
    End With
Next x
MsgBox "Complete"
End Sub

 

[ste33uka]

wow, thanks peter, deleted all rows in 1 second, really appreciate it,
And thanks all others for suggestions

 

[Peter_SSs]

wow, thanks peter, deleted all rows in 1 second, really appreciate it,

You're welcome. Thanks for the follow-up.

 

[Macropod]

thanks but still takes over 15 minutes

It takes less than a second on my laptop. Evidently you have lots of recalculation going on. In that case, insert:
Application.Calculation = xlCalculationManual
after:
Application.ScreenUpdating = False
and insert:
Application.Calculation = xlCalculationAutomatic
before:
Application.ScreenUpdating = True

 

[Alex Blakenburg]

@Peter_SSs loved your solution so I took some time working through it.
If there were a lot of formulas on the rows and based on the principle it faster to delete from the bottom, would it have run faster if:-
After the For i = 1 To UBound(a) we added

b(i, 1) = 0

The sort in the delete section would then have sorted the rows to delete to the bottom.

And then for the delete swapped .Resize(k).EntireRow.Delete for

.Offset(lr - k).Resize(k).EntireRow.Delete

 

[Peter_SSs]

Hi Alex

In any testing that I have done in the past with variations of this code I have found no discernible difference in deleting from top or bottom, the speed is gained from deleting one contiguous block instead of multiple disjoint blocks.
It would be miniscule in time but your suggestion would need one extra step too - to remove all the remaining zeros from the last column.

 

[Alex Blakenburg]

Hi Alex

In any testing that I have done in the past with variations of this code I have found no discernible difference in deleting from top or bottom, the speed is gained from deleting one contiguous block instead of multiple disjoint blocks.
It would be miniscule in time but your suggestion would need one extra step too - to remove all the remaining zeros from the last column.

True. I have had issues in the past where the spreadsheet had lots of lookup and even the sort was slow. I thought the order might matter if you had a lot of look ups but armed with your advice I just tried it on a 3.5k row spreadsheet with lots of columns with formulas which of course confirmed your test results that sorting the rows for deletion to the top or the bottom made very little difference.

I have tucked your code away for future use. Thank you.