VBA 似乎在删除过滤器时删除了整个表

Question

目前有一个 vba 代码循环遍历我的工作簿以删除包含“股息”的行。 数据集通常是标准化的，并且在“A1:G101”的范围内。

除了包含“股息”的行恰好位于第 101 行之外，该代码通常可以正常工作。代码继续删除整个表“A1:G101”以及可见行。

Sub Delete_rows_Dividends()

 Dim ws As Worksheet

  For Each ws In Worksheets
 
   If ws.Name <> "Summary" And ws.Name <> "Dashboard" And ws.Name <> "Signals" Then
    
    On Error Resume Next
    ws.Range("A1:G101").AutoFilter Field:=2, Criteria1:="*Dividend*"
   
    Application.DisplayAlerts = False
    ws.Range("A2:G101").SpecialCells(xlCellTypeVisible).Delete
    Application.DisplayAlerts = True
    
    ws.AutoFilter.ShowAllData
  End If
  
  Next ws
 
End Sub

Answer 1

删除条件行 (AutoFilter)

快速修复

Sub Delete_rows_Dividends()

    Dim ws As Worksheet
    Dim trg As Range ' Table Range
    Dim drg As Range ' Data Range i.e. Table Range without headers

    For Each ws In Worksheets
        Select Case LCase(ws.Name) ' 'LCase' (or 'UCase') to ignore case ('A=a')
        Case "summary", "dashboard", "signals" ' the comma means 'Or'
        Case Else
            ' Remove previous filters.
            If ws.AutoFilterMode Then
                ws.AutoFilterMode = False
            End If
            ' First create the range references...
            Set trg = ws.Range("A1:G101")
            Set drg = ws.Range("A2:G101")
            ' ... only then apply the filter.
            trg.AutoFilter Field:=2, Criteria1:="*Dividend*"
            ' Prevent run-time error if no cells.
            On Error Resume Next
                ' Instead of 'Application.DisplayAlerts', use 'EntireRow'.
                drg.SpecialCells(xlCellTypeVisible).EntireRow.Delete
                ' Note that if you want to preserve possible data to the right
                ' of the table, you will have to create a backward loop
                ' through the areas of the 'special cells range' i.e. probably
                ' use another way.
            On Error GoTo 0
            ' Remove filter.
            ws.AutoFilterMode = False
        End Select
    Next ws
 
End Sub

改进

• 调整常量部分中的值。

Option Explicit

Sub DeleteCriteriaEntireRows()
    
    Const ExceptionsList As String = "Summary,Dashboard,Signals"
    Const ColsAddress As String = "B" ' or "A:G"
    Const fField As Long = 1 ' or 2, if "A:G"
    Const fCriteria As String = "*Dividend*"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")

    Application.ScreenUpdating = False

    Dim ws As Worksheet
    Dim crg As Range ' Columns Range
    Dim lCell As Range ' Last (Bottom-Most) Non-empty Cell (in Columns Range)
    Dim trg As Range ' Table Range
    Dim drg As Range ' Data Range
    Dim lRow As Long ' Last Non-Empty Row
    
    For Each ws In wb.Worksheets
        If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
            If ws.AutoFilterMode Then
                ws.AutoFilterMode = False
            End If
            Set crg = ws.Columns(ColsAddress)
            Set lCell = crg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
            If Not lCell Is Nothing Then
                lRow = lCell.Row
                If lRow > 1 Then
                    Set trg = crg.Resize(lRow)
                    Set drg = trg.Resize(lRow - 1).Offset(1)
                    trg.AutoFilter fField, fCriteria
                    On Error Resume Next
                        drg.SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    On Error GoTo 0
                    ws.AutoFilterMode = False
                End If
            End If
        End If
    Next ws
 
    Application.ScreenUpdating = True

End Sub