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

时间:2016-11-18 22:07:54

标签: excel-vba vba excel

我的问题:我正在尝试删除列AH中表格中的行,而标准是" Del"所以列AH中的任何单元格,我想删除该表中的整行。

我尝试了很多不同的代码,大多数代码都是永久性的,因为我要删除10000多行。我从网站上找到了此代码,但我从subscript out of range Error9行收到错误If Intersect

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")

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

3 个答案:

答案 0 :(得分: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

答案 1 :(得分:0)

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

enter image description here

添加按钮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

答案 2 :(得分:0)

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

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

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

结果

enter image description here

测试

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