excel 根据条件从表宏中删除行

Question

我的问题：我正在尝试删除 AH 列中的表中的行，并且条件是“Del”，因此 AH 列中的任何单元格，我想删除该表中的整行。

我尝试了很多不同的代码，但大多数都需要很长时间，因为我有 10000 多行要删除。我从一个站点找到了这段代码，但我从If Intersect 行收到了一个错误subscript out of range Error9：

Private Sub deleteTableRowsBasedOnCriteria(tbl As ListObject, _
                                           columnName As String, _
                                           criteria As String)

    Dim x As Long, lastrow As Long, lr As ListRow
    lastrow = tbl.ListRows.Count
    For x = lastrow To 1 Step -1
        Set lr = tbl.ListRows(x)
        If Intersect(lr.Range, tbl.ListColumns(columnName).Range).Value = criteria Then
            'lr.Range.Select
            lr.Delete
        End If
    Next x
End Sub

然后我调用 sub 如下：

Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table4")
Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del")

任何帮助都会很棒。谢谢你。

Answer 1

您应该可以只使用AutoFilter 而不是循环。它要快得多。

Sub Macro1()
    Dim wks As Worksheet
    Dim tbl As ListObject
    Dim lastRow As Long
    Dim rng As Range

    Set wks = ActiveWorkbook.Sheets("Sheet1")

    Set tbl = wks.ListObjects("Table4")

    ' Filter and delete all rows that have "Del" in it
    With tbl.Range
        ' Switch off the filters before turning it on
        .AutoFilter
         ' Field:=34 must be equal to the column where you have the criteria in
        .AutoFilter Field:=34, Criteria1:="Del"

        ' Set the range for the filtered cells
        Set rng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        .AutoFilter ' Turn off the filter
        rng.Delete ' Delete the filtered cells
    End With
End Sub

Answer 2

我稍微更改了您的代码并添加了一个按钮来执行删除行功能。我使用按钮标题来显示已删除的行数，以便您知道发生了什么。关键是调用DoEvents，以便在删除行时刷新所有内容并更改按钮标题：

您添加一个按钮CommandButton1 并尝试以下代码：

Private Sub CommandButton1_Click()

Dim rowsDeleted As Long
Call deleteTableRowsBasedOnCriteria("H", "Del")

End Sub

Private Sub deleteTableRowsBasedOnCriteria(columnName As String, criteria As String)
    Dim x As Long, lastrow As Long, lr As ListRow, rowsDeleted As Long, deletedShift As Long
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row

    rowsDeleted = 0
    deletedShift = 0
    For x = lastrow To 1 Step -1
        If Cells(x, Range(columnName & 1).Column) = "Del" Then
            Rows(x).Delete
            rowsDeleted = rowsDeleted + 1
            deletedShift = deletedShift + 1

            If deletedShift >= 30 Then
                CommandButton1.Caption = "Deleted " & rowsDeleted & " rows"
                deletedShift = 0
                DoEvents
            End If
        End If
    Next x

    MsgBox "Total rows deleted: " & rowsDeleted
End Sub

Answer 3

在像这样的大型数据集上，我更喜欢使用数组而不是删除行。这个概念非常简单，您将 Target 单元格值加载到数组 (Data) 中，然后创建第二个相同大小的空数组 (NewData)。接下来，循环遍历 Data 并复制要在 NewData 中保留下一个空行的任何 Data 行。最后，您使用 NewData 覆盖 Target 单元格值，从而有效地删除了您不想保留的行。

实际上我在这里更进一步，添加了一个PreserveFormulas 参数。如果 PreserveFormulas = True 则将公式复制到 NewData，而不仅仅是值。

注意：59507 行每隔一行删除一次。我比较了 Array Delete Data Only、Array Delete Preserve Formulas、Union Method 和 Filter Method。 Download Test Stub

结果

测试

Sub Test()
    Dim tbl As ListObject
    Set tbl = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
    Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del", False)
    Debug.Print
    Set tbl = ThisWorkbook.Worksheets("Sheet2").ListObjects("Table13")
    Call deleteTableRowsBasedOnCriteria(tbl, "AH", "Del", True)
End Sub

代码

Sub deleteTableRowsBasedOnCriteria(tbl As ListObject, columnName As String, criteria As String, PreserveFormulas As Boolean)
    Dim Start: Start = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim Data, Formulas, NewData
    Dim col As Long, pos As Long, x As Long, y As Long
    col = Columns(columnName).Column
    Data = tbl.DataBodyRange.Value
    If PreserveFormulas Then Formulas = tbl.DataBodyRange.Formula

    ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))

    For x = 1 To UBound(Data, 1)
        If Data(x, col) <> criteria Then
            pos = pos + 1
            For y = 1 To UBound(Data, 2)
                If PreserveFormulas Then
                    NewData(pos, y) = Formulas(x, y)
                Else
                    NewData(pos, y) = Data(x, y)
                End If
            Next
        End If
    Next
    tbl.DataBodyRange.Formula = NewData
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Debug.Print "Preserve Formulas: "; PreserveFormulas
    Debug.Print "Original RowCount: "; UBound(Data, 1); " Column Count: "; UBound(Data, 2)
    Debug.Print "New RowCount: "; pos
    Debug.Print UBound(Data, 1) - pos; " Rows Deleted"
    Debug.Print "Execution Time: "; Timer - Start; " Second(s)"
End Sub