Excel Macro is getting stuck in loop while deleting rows

Question

I'm running into an issue where my vba macro is getting stuck and excel freezes. I have narrowed it down to the do until loop but can't seem to get past it. I've tried adding forced wait times to see if that would help but to no avail.

The purpose of the macro is to delete all rows under specific headers until only one row with the value 'Net Change' is remaining. So in the example below only the Headers and the 'Net Change' rows will remain. As always any help is appreciated.

Edit 1: All other rows in the worksheet need to remain intact when running this macro. My thought process was locate the header from the array and delete the unwanted rows beneath it and continue to the next header. There are other headers with information I still need to see.

Sub Delete_Rows_NotNetChange()

Dim deleteNotNetChange As Variant
Dim sr As Range
Dim fr As Range

With ActiveSheet

Set sr = ActiveSheet.Range("A:A")

Application.ScreenUpdating = False

deleteNotNetChange = Array("4008 - Tenant Paid Trash Fee", "4015 - Guardian Water (Mulberry)", "6003 - Leasing Fee (3rd Party)", _
"6277 - Property Cleaning", "6403 - Water", "6408 - Trash and Recycling", "6515 - Parking Garage", "6612 - Property Manager Salary", _
"6622 - Workman's Comp Insurance", "6633 - Coffee Bar /  Machine Supplies", "6639 - Telephone Service")

For Each Header In deleteNotNetChange

    On Error Resume Next
    
    Range(Cells.Find(Header).Address).Select
    
    ActiveCell.Offset(1, 0).Select
    
    Do Until InStr(1, ActiveCell.Value, "Net Change") > 0
       On Error Resume Next
       ActiveCell.EntireRow.Delete
    Loop

Next Header

Application.ScreenUpdating = True

End With

End Sub

Answer 1

Are there any locked cells? Comment out all

On Error Resume Next

lines and see if there are any errors thrown.

Answer 2

Delete Rows with Criteria

• Combines each cell between a value from the array and the string "Net Change" into a range and deletes its rows in one go.

Application.Match feat. Union

Option Explicit

Sub Delete_Rows_NotNetChange()

    Dim deleteNotNetChange As Variant ' Exceptions Array
    deleteNotNetChange = Array("4008 - Tenant Paid Trash Fee", "4015 - Guardian Water (Mulberry)", "6003 - Leasing Fee (3rd Party)", _
    "6277 - Property Cleaning", "6403 - Water", "6408 - Trash and Recycling", "6515 - Parking Garage", "6612 - Property Manager Salary", _
    "6622 - Workman's Comp Insurance", "6633 - Coffee Bar /  Machine Supplies", "6639 - Telephone Service")
    
    Dim srg As Range ' Source Range
    With ActiveSheet
        Dim lRow As Long: lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set srg = .Range("A2:A" & lRow)
    End With
    
    Dim drg As Range ' Delete Range
    Dim sCell As Range ' Source Cell
    Dim mIndex As Variant ' Match Index
    Dim dCount As Long ' Deleted Rows Count
    Dim Writing As Boolean ' Writing Boolean
    For Each sCell In srg.Cells
        If Writing Then
            If InStr(1, sCell.Value, "Net Change", vbTextCompare) > 0 Then
                Writing = False
            Else
                If drg Is Nothing Then
                    Set drg = sCell
                Else
                    Set drg = Union(drg, sCell)
                End If
                dCount = dCount + 1
            End If
        Else
            mIndex = Application.Match(sCell.Value, deleteNotNetChange, 0)
            If IsNumeric(mIndex) Then
                Writing = True
            End If
        End If
    Next sCell
    
    If Not drg Is Nothing Then
        Application.ScreenUpdating = False
        drg.EntireRow.Select
        Application.ScreenUpdating = True
    End If

    Select Case dCount
    Case 0
        MsgBox "No rows deleted", vbExclamation, "Fail?"
    Case 1
        MsgBox "1 row deleted.", vbInformation, "Success"
    Case Else
        MsgBox dCount & " rows deleted.", vbInformation, "Success"
    End Select

End Sub

Answer 3

Normally scan upwards if you are deleting rows. Edit: Revised to only delete selected sections and leave other sections intact.

Option Explicit

Sub Delete_Rows_NotNetChange()
    Const COL = "A"

    Dim ws As Worksheet
    Dim i As Long, iLastRow As Long, n As Long, bDelete As Boolean
    Dim s As String, iNet As Long
   
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    dict.Add "4008 - Tenant Paid Trash Fee", 1
    dict.Add "4015 - Guardian Water (Mulberry)", 1
    dict.Add "6003 - Leasing Fee (3rd Party)", 1
    dict.Add "6277 - Property Cleaning", 1
    dict.Add "6403 - Water", 1
    dict.Add "6408 - Trash and Recycling", 1
    dict.Add "6515 - Parking Garage", 1
    dict.Add "6612 - Property Manager Salary", 1
    dict.Add "6622 - Workman's Comp Insurance", 1
    dict.Add "6633 - Coffee Bar /  Machine Supplies", 1
    dict.Add "6639 - Telephone Service", 1
  
    Set ws = ActiveSheet
    iLastRow = ws.Cells(Rows.Count, COL).End(xlUp).Row
    For i = iLastRow To 1 Step -1
        s = Trim(ws.Cells(i, COL))
        If InStr(1, s, "Net Change") > 0 Then
            iNet = i - 1
        ElseIf dict.exists(s) And iNet > i Then
            ws.Rows(iNet & ":" & i + 1).EntireRow.Delete
            n = n + iNet - i
        End If
    Next
    MsgBox n & " rows deleted"

End Sub