删除组合筛选行

Option Explicit

Sub FilterCheckDeleteUniques()
    
    Application.ScreenUpdating = False
    
    ' Reference the worksheet ('ws').
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Turn off AutoFilter.
    If ws.AutoFilterMode Then ws.AutoFilterMode = False 
    
    ' Reference the table range ('rg') (has headers).
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    
    ' Reference the data range ('drg') (no headers).
    Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)

    ' Write the data for the 3rd and 4th columns to an array.
    ' (Column, Greater Than or Equal, Less Than or Equal)
    Dim InRangeArr() As Variant
    InRangeArr = Array(VBA.Array(3, 0, 4), VBA.Array(4, 1, 5))
    
    ' Write the values from the 2nd column to an array ('Data').
    Dim Data As Variant: Data = GetRange(drg.Columns(2))
    
    ' Write the unique values from the array to the 'keys'
    ' of a dictionary ('dict').
    Dim dict As Object: Set dict = DictColumn(Data)
    Erase Data
    
    ' Declare additional variables.
    Dim frg As Range
    Dim cfrg As Range
    Dim iKey As Variant
    
    ' Loop through the 'keys' of the dictionary.
    For Each iKey In dict.Keys
        ' Reference the current criteria filtered rows if conditions
        ' are met.
        Set cfrg = RefFilteredRangeSpecial(rg, drg, CStr(iKey), InRangeArr)
        ' Combine the current criteria visible rows into a range.
        If Not cfrg Is Nothing Then
            If frg Is Nothing Then
                Set frg = cfrg
            Else
                Set frg = Union(frg, cfrg)
            End If
        End If
    Next iKey
    
    ' Delete all combined rows in one go.
    If Not frg Is Nothing Then frg.Delete xlShiftUp
    
    Application.ScreenUpdating = True

    ' Inform.
    MsgBox "Operation finished.", vbInformation

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a column ('ColumnIndex')
'               of a 2D array ('Data') in the keys of a dictionary.
' Remarks:      Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumn( _
    ByVal Data As Variant, _
    Optional ByVal ColumnIndex As Variant) _
As Object
    Const ProcName As String = "DictColumn"
    On Error GoTo ClearError
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim c As Long
    
    If IsMissing(ColumnIndex) Then
       c = LBound(Data, 2) ' use first column index
    Else
       c = CLng(ColumnIndex)
    End If
    
    Dim Key As Variant
    Dim r As Long
    
    For r = LBound(Data, 1) To UBound(Data, 1)
        Key = Data(r, c)
        If Not IsError(Key) Then ' exclude error values
            If Len(CStr(Key)) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
   
    If dict.Count = 0 Then Exit Function ' only error values and blanks
    
    Set DictColumn = dict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      References a filtered range if conditions are met...
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFilteredRangeSpecial( _
    ByVal rg As Range, _
    ByVal drg As Range, _
    ByVal Criteria As String, _
    InRangeArr() As Variant) _
As Range
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = rg.Worksheet
    
    ' Filter the table range.
    rg.AutoFilter 2, Criteria
    
    ' Reference the visible data range ('vdrg'), the filtered rows.
    Dim vdrg As Range: Set vdrg = drg.SpecialCells(xlCellTypeVisible)
    
    ' Remove the autofilter.
    ws.AutoFilterMode = False
    
    ' Declare additional variables.
    Dim irg As Range
    Dim iCell As Range
    Dim iValue As Variant
    Dim n As Long
    Dim IsInRange As Boolean
    
    ' Loop.
    For n = LBound(InRangeArr) To UBound(InRangeArr)
        Set irg = Intersect( _
            vdrg, ws.Columns(rg.Columns(InRangeArr(n)(0)).Column))
        For Each iCell In irg.Cells
            iValue = iCell.Value
            If VarType(iValue) = vbDouble Then ' is a number
                If iValue >= InRangeArr(n)(1) _
                        And iValue <= InRangeArr(n)(2) Then ' in range
                    IsInRange = True
                    Exit For
                'Else ' not in range; do nothing
                End If
            End If
        Next iCell
        If IsInRange Then ' in range found
            Set RefFilteredRangeSpecial = vdrg
            Exit For
        'Else ' in range not found; do nothing
        End If
    Next n
    
End Function