Macro to delete Zero and blank Rows

[howard]

I have a sheet called "Summary"

I have tried to write code to delete the rows from Row 25 onwards up to the last row in Col A, where Col B contains a zero or blank

The macro takes a few mins to run and there is a maximum of 1000 rows

It would be appreciated if someone could kindly amend my code

 Sub deleteRowsSummary()
    Dim lastRow As Long
    Dim i As Long
    With Sheets("Summary")
.Unprotect
    'Get the last row in column A
    lastRow = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
    
    'Loop through rows 25 to last row in column B
    For i = 25 To lastRow
        If Sheets("Summary").Range("B" & i).Value = "" Or Sheets("Summary").Range("B" & i).Value = 0 Then
            Sheets("Summary").Range("B" & i).EntireRow.Delete
            i = i - 1 'since the row is deleted, need to decrement i to re-check the same row number
        End If
    Next i
    .Protect
 End With 
End Sub

 

[Norie]

When deleting you should loop from the bottom up, and to help speed things up you can turn off screen updating and set calculation to manual.

Option Explicit

Sub deleteRowsSummary()
Dim lastRow As Long
Dim I As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    With Sheets("Summary")
        .Unprotect
        'Get the last row in column A
        lastRow = .Range("A" & Rows.Count).End(xlUp).Row

        'Loop through rows 25 to last row in column B
        For I = lastRow To 25 Step -1
            If .Range("B" & I).Value = "" Or Sheets("Summary").Range("B" & I).Value = 0 Then
                .Range("B" & I).EntireRow.Delete
            End If
        Next I
        .Protect
       
    End With
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
End Sub

Other than that, if you really want to speed things up look at filtering the data and deleting rather than looping.