Excel 宏在删除行时陷入循环

Question

我遇到了一个问题，即我的 vba 宏卡住并且 excel 冻结。我已将其缩小到 do until 循环，但似乎无法通过它。我尝试过添加强制等待时间，看看是否有帮助，但无济于事。

宏的目的是删除特定标题下的所有行，直到只剩下一个值为“Net Change”的行。因此，在下面的示例中，仅保留标题和“净变化”行。一如既往地感谢任何帮助。

编辑 1：运行此宏时，工作表中的所有其他行都需要保持不变。我的思考过程是从数组中找到标题并删除它下面不需要的行并继续下一个标题。我还需要查看其他包含信息的标题。

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

有没有上锁的牢房？全部注释掉

On Error Resume Next

行，看看是否有任何错误抛出。

Answer 2

如果要删除行，通常向上扫描。 编辑：修改为仅删除选定的部分并保持其他部分不变。

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

Answer 3

使用标准删除行

• 将数组中的值与字符串“Net Change”之间的每个单元格组合到一个范围内，并一次性删除其中的行。

Application.Match 壮举。 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