I need a faster excel vba macro that deletes every row with a 0 in Column A

Question

Right now, I'm using the macro below to delete every row with a 0 in column A. The problem is that it is too slow. It took about thirty seconds to do the job for two thousand rows, but I need a macro to work on 300,000 rows. The current macro freezes my computer with that many rows. I've tried the first five solutions on this site with no luck: http://www.dummies.com/software/microsoft-office/excel/10-ways-to-speed-up-your-macros/

Sub Loop_Example()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'We use the ActiveSheet but you can replace this with
    'Sheets("MySheet")if you want
    With ActiveSheet

        'We select the sheet so we can change the window view
        .Select

        'If you are in Page Break Preview Or Page Layout view go
        'back to normal view, we do this for speed
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView

        'Turn off Page Breaks, we do this for speed
        .DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = .UsedRange.Cells(1).Row
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

        'We loop from Lastrow to Firstrow (bottom to top)
        For Lrow = Lastrow To Firstrow Step -1

            'We check the values in the A column in this example
            With .Cells(Lrow, "A")

                If Not IsError(.Value) Then

                    If .Value = "0" Then .EntireRow.Delete
                    'This will delete each row with the Value "ron"
                    'in Column A, case sensitive.

                End If

            End With

        Next Lrow

    End With

    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With

End Sub

Answer 1

I can't comment on whether this is the fastest way but it's probably the shortest in terms of actual code that you'll find on these answers:

'get number of cells in A column
Dim x as long: x = WorksheetFunction.CountA(ActiveSheet.Range("A:A"))
'AutoFilter to pick up only zeroes
ActiveSheet.Range("$A$1:$Z" & x).AutoFilter Field:=1, Criteria1:=0
'delete what is currently filtered
ActiveSheet.Rows("2:" & x).Delete Shift:= xlUp

EDIT:

ActiveSheet.Range("$A$1:$Z" & x).AutoFilter

-adding this on the end turns the autofilter off afterwards

The autofilter here is sorting by column A (Field 1 in A:Z) and looking for zeroes (Criteria:= 0) - might need adapting slightly for your purposes but it's simple enough

note: This does take a while with 300,000 + rows - I have a routine which takes out about 200,000 + rows out of a data set like this on a bi-weekly basis. Which probably sounds mad, except I'm only using that data to summarise it in a Pivot Table - once that's been refreshed, most of the data can go.

Answer 2

If the data does not contain any formulae then refactoring could shave maybe 10 to 15 seconds off the execution time.

---

Sub DeleteRows()
    Const PageSize As Long = 20000
    Dim rw As Range
    Dim Data
    Dim lStart As Long, lEnd As Long, lNextRow As Long
    Dim list As Object: Set list = CreateObject("System.Collections.ArrayList")

    ToggleEvents False
    MonitorTimes True

    With Worksheets("Sheet1").UsedRange
        For Each rw In .Rows
            If Not IsError(rw.Cells(1).Value) Then
                If rw.Cells(1).Value <> 0 Then list.Add rw.Formula
            End If
        Next

        MonitorTimes

        .Cells.ClearContents
        For lStart = 0 To list.Count Step PageSize
            lEnd = IIf(lStart + PageSize - 1 <= list.Count, PageSize, list.Count - lStart)
            Data = Application.Transpose(list.GetRange(lStart, lEnd).ToArray)
            Data = Application.Transpose(Data)
            With .Range("A1").Offset(lNextRow)
                .Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
                lNextRow = lNextRow + PageSize
            End With
        Next
    End With

    MonitorTimes

    ToggleEvents True
End Sub

Static Sub ToggleEvents(EnableEvents As Boolean)
    Dim CalcMode As Long
    If EnableEvents Then
        With Application
            CalcMode = .Calculation
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
        End With
    Else
        With Application
            .ScreenUpdating = True
            .Calculation = CalcMode
        End With
    End If
End Sub

Static Sub MonitorTimes(Optional ResetVariables As Boolean)
    Dim tLoad, Start
    Dim RowCount As Long, ColumnCount As Long

    If ResetVariables Then
        Start = 0
        tLoad = 0
    End If

    With Worksheets("Sheet1")
        If Start = 0 Then
            Start = Timer
            Debug.Print "Before: "; "Rows->"; WorksheetFunction.CountA(.Columns(1)); "Columns->"; WorksheetFunction.CountA(.Rows(1))
        ElseIf tLoad = 0 Then
            tLoad = Timer - Start
        Else
            Debug.Print "After: "; "Rows->"; WorksheetFunction.CountA(.Columns(1)); "Columns->"; WorksheetFunction.CountA(.Rows(1))
            Debug.Print "Load Time in Second(s): "; tLoad
            Debug.Print "Write Time in Second(s): "; Timer - Start - tLoad
            Debug.Print "Execution Time in Second(s): "; Timer - Start
        End If
    End With

End Sub

Sub RestoreTestData()
    Worksheets("Original").Cells.Copy Worksheets("Sheet1").Cells
    ThisWorkbook.Save
End Sub

Answer 3

Perhaps using something like this

 Sub DeleteZeroRows()

    Dim a() As Variant
    Dim l As Long

    a = Range("a1:a300000").Value

    For l = UBound(a) To 1 Step -1
       If a(l, 1) = 0 Then
          Debug.Print "Row " & l & " delete"
          Rows(l).EntireRow.Delete
      End If
   Next l

    End Sub

Answer 4

Don't read 1-by-1. Delete all at once.

Sub Loop_Example()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long

    Dim Data As Variant
    Dim DelRange As Range

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'We use the ActiveSheet but you can replace this with
    'Sheets("MySheet")if you want
    With ActiveSheet

        'We select the sheet so we can change the window view
        .Select

        'If you are in Page Break Preview Or Page Layout view go
        'back to normal view, we do this for speed
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView

        'Turn off Page Breaks, we do this for speed
        .DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = .UsedRange.Cells(1).Row
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

        Data = .Range("A1:A" & Lastrow)

        'We loop from Lastrow to Firstrow (bottom to top)
        For Lrow = Lastrow To Firstrow Step -1

            If Not IsError(Data(Lrow, 1)) And Not IsEmpty(Data(Lrow, 1)) Then
               If Data(Lrow, 1) = 0 Then
                  If DelRange Is Nothing Then
                     Set DelRange = .Rows(Lrow)
                  Else
                     Set DelRange = Union(DelRange, .Rows(Lrow))
                  End If
               End If
            End If

        Next Lrow

        DelRange.Delete

    End With

    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With

End Sub