问excel VBA在自动筛选后删除行

EN

Option Explicit

Sub deleteFilteredRows()
  
    ' Define constants.
  
    Const wsName As String = "Sales Pipeline Report"
    Const FirstCell As String = "E2"
    Const afField As Long = 4
    Const Criteria As String = "Onboarding"
      
    ' Define Source Range.
    
    ' Define Success Boolean.
    Dim Success As Boolean
    ' Define Worksheet.
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(wsName)
    ' Define First Cell Range ('cel').
    Dim cel As Range
    Set cel = ws.Range(FirstCell)
    ' Define Current Region ('rng').
    Dim rng As Range
    Set rng = cel.CurrentRegion
    ' Define Source Range ('rng').
    Set rng = cel _
      .Resize(rng.Rows.Count + rng.Row - cel.Row, _
              rng.Columns.Count + rng.Column - cel.Column)
    
    ' Delete filtered rows.
    
    ' Turn off screen updating.
    Application.ScreenUpdating = False
    ' Turn off AutoFilter.
    If ws.AutoFilterMode Then
        ws.AutoFilterMode = False
    End If
    ' Filter Source Range.
    rng.AutoFilter Field:=afField, Criteria1:=Criteria
    ' Try to define Filtered Range ('rng').
    Dim dRng As Range
    On Error Resume Next
    Set dRng = rng.Resize(rng.Rows.Count - 1).Offset(1) _
                                             .SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    ' Validate Filtered Range.
    If dRng Is Nothing Then
        GoTo SafeExit
    End If
    ' Delete entire rows of Filtered Range.
    dRng.EntireRow.Delete
    ' Validate Success.
    Success = True
SafeExit:
    ' Clear filter.
    ws.ShowAllData
    ' Turn on screen updating.        
    Application.ScreenUpdating = True

    ' Inform user.
    
    If Success = True Then
        MsgBox "Rows of filtered data deleted.", vbInformation, "Success"
    Else
        MsgBox "No action taken.", vbCritical, "Fail"
    End If

End Sub