Increasingly Long Runtime for Macro

Question

My code works, but the problem is that it is taking an increasingly long time to run, with the time required to complete calculations increasing every time I use the macro. I've tried a variety of variations and modifications with the syntax, but as I'm pretty new to VBA, I haven't made a whole lot of progress.

Here's the code I'm running (Note, it is running as a subset, and ScreenUpdate = False):

Public Sub deleteRows()

    Dim lastRow As Long
    Dim rng As Range
    With ActiveSheet
        .AutoFilterMode = False
        lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        '~~> Set the range of interest, no need to include the entire data range
            With .Range("B2:F" & lastRow)
                .AutoFilter Field:=2, Criteria1:="=0.000", Operator:=xlFilterValues
                .AutoFilter Field:=5, Criteria1:="=0.000", Operator:=xlFilterValues
            End With
        .Range("B1:F" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilterMode = False
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End With
    MsgBox Format(Time - start, "hh:mm:ss")

End Sub

This code basically removes zero-valued results from the data by deleting an entire row. Initially, it ran in about 12 seconds, but that soon became 55 second, which has progressed into increasing long runtimes, with a 'fast' now being in the 5 minuet range. Below is a spreadsheet with the recorded runtimes and corresponding changes made:

Runtime   Changes
6:30  None
7:50  None
5:37  Manually stepped through code
7:45  Run with .cells instead of .range("B1:B" & lastRow)
5:21  Run with .Range(B:B)  instead of .range("B1:B" & lastRow)
9:20  Run with application.calculation disabled/enabled, range unchanged
5:35  Run with application.enableEvents disabled/enabled, range unchanged
11:08 Run with application.enableEvents disabled/enabled, Range(B:B)
5:12  None
7:57  Run with Alternative code (old code)
5:45  Range changed to .Range(cells(2,2), Cells(lastRow,2)
10:25 Range changed to .Range(cells(2,2), Cells(lastRow,2), Application.Calculation Disabled/enabled
5:34  Range set to rngB  for .delete portion (range assigned to variable)
9:59  Range set as rng("B1:F" & lastRow)
5:58  Changed system settings for Excel to "High Priority", code reverted to original
9:41  Rerun of old code for comparison
9:26  Reun with change in old code criteria to "0.000"
0:10  Moved SpecialCells……..Delete into 2nd With/End With
5:15  Rerun  SpecialCells……..Delete into 2nd With/End With
11:31 Rerun  SpecialCells……..Delete into 2nd With/End With
11:38 Excel restart; Rerun  SpecialCells……..Delete into 2nd With/End With
5:18  Excel restart; Rerun  SpecialCells……..Delete into 2nd With/End With
6:49  Removed 2nd with 'loop'; all data put into first with statement

I did some research online, and it looks like this might be a known issue with Excel when working with large datasets, and as mine is ~51k rows, I can see how this might be the case.

...A macro that required several seconds to complete in an earlier version of Excel may require several minutes to complete in a later version of Excel. Alternatively, if you run a macro a second time, the macro may take twice as long to run as it did the first time.

Source

Is there any way to make this run faster, like it initially did? Why is this happening?

Answer 1

This won't solve the long run times of your code if the issue is the EntireRow.Delete method. I assume you still want those rows deleted and stackoverflow would be the place to get a workaround or solution.

That being said your code should be reviewed.

---

Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Never use Select unless you are making some macro to find a range for the user. Use Rows("1:1").Insert .... Making these concatenations should be priority #1 after recording a macro. Also you are not declaring the parent of Rows. ActiveSheet is implicitly the parent but Rows is already nested in a With statment. Just put the period .Rows("1:1")... to make it explicit.

---

With ActiveSheet

As you said, this is being called as a sub function. If your project grows to include more sheets, assuming ActiveSheet is the sheet you want to manipulate won't be safe. Any Sub not meant to be an outermost Sub should not use ActiveSheet, ActiveBook, ActiveCell, or Selection. Sheets, books, and ranges should be passed as an argument.

---

This variable isn't being used. Delete it.

Dim rng As Range

---

You get the last row by going to the bottom of the sheet and iterating up until you find the bottom of your data.

lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row

Instead get the bottom of the range containing data:

lastRow = .UsedRange.Rows.Count

---

Now there is the general steps that your macro takes. It operates like user interaction, which is usually not the best way to approach it. The steps you take:

• AutoFilter the range
  • only rows with columns "C" and "F" are visible
• Delete all visible rows in the range

It makes perfect sense in a user interface side but from a programming side is unnecessarily indirect. Rows to delete are marked by remaining visible and then deleted. What if something else has marked rows as invisible? I would suggest iterating over all rows in the range and deleting those that should be.

Public Sub DeleteRows()
    ' ActiveSheet or Range("B2:F" & lastRow) should be passed
    Dim sheet as Worksheet
    set sheet = ActiveSheet

    Dim lastRow As Long
    lastRow = sheet.UsedRange.Rows.Count

    Dim table as Range        
    set table = sheet.Range("B2:F" & lastRow)

    Dim l as Long
    For l = lastRow to 1 step -1

        If ShouldBeDeleted(table.rows(l)) Then 

            table.rows(l).EntireRow.Delete shift:=xlUp

        End If

    Next l

    ' These should be in the outside Sub
    sheet.Range("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    MsgBox Format(Time - start, "hh:mm:ss")

End Sub
Function ShouldBeDeleted(row_range as Range) as Boolean

    ShouldBeDeleted = (row_range.cells(1, 2) = 0 And row_range.cells(1, 5) = 0)

End Function

Pulling bits out like ShouldBeDeleted might seem verbose but there is a better name for it. There is something special about those rows, and I would rename the function IsX where X describes what those rows are. Also, columns "C" and "F" seem to be special for your worksheet. If they are so, declare them as constants

Const IMPORTANT_COL_1 As String = "C"
Const IMPORTANT_COL_2 As String = "F"

Sorting Optimizations

If sorting the rows of the table is allowed and 0 is the minimum then you could sort the table and only iterate over the rows that you need to delete.

Public Sub DeleteRows(table as Range)

    Dim lastRow As Long
    lastRow = table.Rows.Count

    With table.Parent.Sort

        .SortFields.Clear
        .SortFields.Add key:=table.Range(IMPORTANT_COL_1 & ":" & IMPORTANT_COL_1)
        .SortFields.Add key:=table.Range(IMPORTANT_COL_2 & ":" & IMPORTANT_COL_2)
        .SetRange table
        .Apply

    End With

    Dim botRow as Long
    botRow = 1

    While ShouldBeDeleted(table.rows(botRow))
        botRow = botRow + 1
    Wend

    table.range("1:" & botRow).Delete shift:=xlUP

End Sub