VBA宏通过特定单元格值过滤表格并删除所有行

Question

我的宏的目的是执行以下步骤： 1：过滤表查看 D 列以检索所有“0”值 2：删除所有值为“0”的行 3：删除过滤器。

问题是我的表有 75,000 多行数据，所以我不断收到警报说我有太多数据。我尝试了一个循环宏，但执行这项工作需要很长时间，所以我现在正在研究一个执行上述步骤的宏。我的代码不断挂断以删除我选择的单元格范围。 （我的范围超出了表格范围，因为该表格的行数总是可变的）。

错误：“oject'_Worksheet' 的方法 'Range' 失败

我假设我需要指定表中的确切行数。如何更改代码，以便不必每次执行宏时都更改范围？

这是我目前所拥有的：

Sub Delete_Zero_Rows()

Dim ws As Worksheet
  Set ws = ThisWorkbook.Worksheets("Status")
  ws.Activate

  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0
  ws.Range("B3:F1").AutoFilter Field:=4, Criteria1:="0"


  Application.DisplayAlerts = False
    ws.Range("B4:F").SpecialCells(xlCellTypeVisible).Delete
  Application.DisplayAlerts = True
  On Error Resume Next
    ws.ShowAllData
  On Error GoTo 0

End Sub

Answer 1

一个循环应该可以很好地处理 75,000 行。关闭屏幕更新以加快速度。试试这个：

Sub DeleteZeroRows()
    Dim LastRow As Long, n As Long
    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For n = LastRow To 1 Step -1
        If Cells(n, 5).Value = 0 Then Cells(n, 5).EntireRow.Delete
    Next n
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

请注意，我正在向后退（自下而上），因此当该行被删除并向上移动时，它不会更改您在下一次循环迭代中移动到的行号。

另请注意Cells(n, 5)，其中5 是列（“E”），是我要查找零的位置。

Answer 2

如果要过滤“D”列，则从“B”列开始时为第三个

Sub Main
    With ThisWorkbook.Worksheets("Status")
        .ShowAllData
        With .Range("B1", .Cells(.Rows.Count, 2).End(xlUp))
            .AutoFilter Field:=3, Criteria1:="0"
            On Error Resume Next
            .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Delete
           On Error GoTo 0
        End With 
        .AutofilterMode = False
    End With 
End Sub

Answer 3

修改数组中的范围

• 以下代码仅在范围内有值时才有效，不是 公式。如果有公式，则返回值。

• 以下代码会将整个范围复制到一个数组中， 将检查每一行的条件，如果没有找到，将 （过度）写入同一个数组导致数组太大，但会 然后以 3 种可能方式中的 1 种方式 (cWriteDelete) 写回 范围：

  1. 它将空字符串 ("") 写入数组的其余部分，并 将其粘贴回范围。
  2. 它会将数组原样复制到范围中并删除 不必要的行。
  3. 它会将数组原样复制到范围中并删除 不必要的范围。

• 为什么不调整数组的大小？

  数组是一个2D数组，我们不能调整它的第一个维度（rows）。

代码

Sub Delete_Zero_Rows()

    Const cSheet As String = "Status"       ' Worksheet Name
    Const cRange As String = "A:F"          ' Source Columns Range Address
    Const cFR As Long = 4                   ' First Row Number
    Const cCol As Variant = "E"             ' Criteria Column Letter/Number
    Const cCrit As Long = 0                 ' Criteria
    Const cWriteDelete As Long = 2          ' 1 - Write "" to array
                                            ' 2 - Delete remaining rows
                                            ' 3 - Delete remaining range

    Dim Rng As Range      ' Last Used Cell Range In Criteria Column,
                          ' Source/Target Range
    Dim vntST As Variant  ' Source/Target Array
    Dim ACC As Long       ' Array Criteria Column Number
    Dim i As Long         ' Source Array Row Counter
    Dim j As Long         ' Source/Target Array Column Counter
    Dim k As Long         ' Target Array Row Number (Counter)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    On Error GoTo ProcedureExit   ' Safely exit program.

    With ThisWorkbook.Worksheets(cSheet)

        '************************************************
        ' Last Used Cell Range in Criteria Column (Rng) '
        '************************************************

        ' Calculate Last Used Cell Range in Criteria Column.
        Set Rng = .Columns(cCol).Find("*", , xlFormulas, _
                xlWhole, xlByColumns, xlPrevious)
        ' Check if all cells in Criteria Column (cCol) are empty i.e. Last Used
        ' Cell Range in Criteria Column (Rng) is Nothing.
        If Rng Is Nothing Then  ' Inform user.
            MsgBox "No Data in Column '" & Split(.Cells(1, cCol).Address, _
                    "$")(1) & "'.", vbInformation, "Empty Column"
            GoTo ProcedureExit  ' Safely exit program.
        End If

        '******************************
        ' Source (Target) Range (Rng) '
        '******************************

        ' Calculate Source/Target Range (Rng) from Source Columns Range(cRange).
        Set Rng = .Columns(cRange).Resize(Rng.Row - cFR + 1).Offset(cFR - 1)
        ' Copy Source/Target Range (Rng) to Source/Target Array (vntST).
        vntST = Rng

        '******************************
        ' Source/Target Array (vntST) '
        '******************************

        ' Calculate Array Criteria Column Number.
        ACC = .Columns(cCol).Column
        ' Loop through rows (i) of Source/Target Array (vntST).
        For i = 1 To UBound(vntST)
            ' Check if value of current row (i) in Array Criteria Column (ACC)
            ' does not equal to Criteria  (cCrit).
            If vntST(i, ACC) <> cCrit Then
                ' Count (add 1 to) Target Array Row Number (k).
                k = k + 1
                ' Loop through columns(j) of Source/Target Array (vntST).
                For j = 1 To UBound(vntST, 2)
                    ' Write from current row(i) in column(j) to current row(k)
                    ' in column (j) of Source/Target Array (vntST).
                    ' Note: Data is being overwritten since always k <= j.
                    vntST(k, j) = vntST(i, j)
                Next
            End If
        Next
        ' Check if Target Array Row Number is equal to the number of rows in
        ' Source/Target Array (or in Source/Target Range).
        If k = UBound(vntST) Then ' or k = Rng.Rows.Count; Inform user.
            MsgBox "No cell containing '" & cCrit & "' in Column '" _
                    & Split(.Cells(1, cCol).Address, "$")(1) & "' found.", _
                    vbInformation, "Nothing Changed"
            GoTo ProcedureExit  ' Safely exit program.
        End If

        Select Case cWriteDelete
            Case 1  ' Slower version.
                ' Loop through the remaining rows (i) of Source/Target
                ' Array (vntST) starting from the current Target Array Row
                ' Number (k) increased by 1 (next).
                For i = k + 1 To UBound(vntST)
                    ' Loop through columns(j) of Source/Target Array (vntST).
                    For j = 1 To UBound(vntST, 2)
                        ' Write empty strings ("") to current row(i) in
                        ' column (j) of Source/Target Array (vntST)
                        vntST(i, j) = ""
                    Next
                Next

                '******************************
                ' Target (Source) Range (Rng) '
                '******************************

                ' Copy completely modified Source/Target Array (vntST)
                ' to Source/Target Range (Rng).
                Rng = vntST

            Case 2  ' Faster Version.

                '******************************
                ' Target (Source) Range (Rng) '
                '******************************

                ' Copy not completely modified Source/Target Array (vntST)
                ' to Source/Target Range (Rng).
                Rng = vntST

                ' Delete remaining (not modified) rows greater than current
                ' Target Array Row Number (k) increased by First Row (cFR),
                ' i.e. starting from the calculated row:
                ' (k + 1) + (cFR - 1) = k + cFR.
                .Rows(k + cFR & ":" & Rng.Rows.Count + cFR - 1).Delete

            Case 3  ' Faster Version.

                '******************************
                ' Target (Source) Range (Rng) '
                '******************************

                ' Copy not completely modified Source/Target Array (vntST)
                ' to Source/Target Range (Rng).
                Rng = vntST

                ' Delete remaining (not modified) range.
                .Columns(cRange).Resize(Rng.Rows.Count - k) _
                        .Offset(k + cFR - 1).Delete ' Clear, ClearContents
            Case Else

        End Select

    End With

ProcedureExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub