如何在已应用Autofilter的列上添加二次Autofilter（VBA实现）

需求概述 #

• 现有代码通过Dictionary实现自定义自动筛选，需新增独立Sub过程，在已过滤的列上执行二次筛选
• 执行流程：先运行原有代码完成第一次过滤，关闭工作簿后，再通过新增过程对可见单元格筛选包含*30*的内容
• 约束：不使用辅助列/工作表，保留原有代码，仅新增过程

原有筛选代码 #

Option Explicit
Option Compare Text

Sub Filter_the_Filtered_Column()

    Const filter_Column As Long = 2
    
    Dim filter_Criteria() As Variant
    filter_Criteria = Array("*Id*", "*Name*", "*Color*")
    
    Dim ws As Worksheet:    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim rg As Range
    Set rg = ws.UsedRange.Resize(ws.UsedRange.Rows.Count - 1).Offset(1)  '(UsedRange except the first Row)
    
    Dim rCount As Long, arr() As Variant, dict As Object, el, r As Long
    rCount = rg.Rows.Count - 1
    arr = rg.Columns(filter_Column).Resize(rCount).Offset(1).Value         'Write the values from criteria column to an array.
        
    Set dict = CreateObject("Scripting.Dictionary")                        'Write the matching strings to the keys (a 1D array) of a dictionary.
 
    For r = 1 To UBound(arr)                                                'Loop through the elements of the array.
        For Each el In filter_Criteria
            If arr(r, 1) Like el Then dict(arr(r, 1)) = vbNullString: Exit For
        Next el
    Next r
    
    If dict.Count > 0 Then
        rg.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues   'use the keys of the dictionary (a 1D array) as a Criteria
    End If

End Sub

新增二次筛选过程 #

以下是独立的二次筛选Sub，可在第一次过滤并重新打开工作簿后运行：

Option Explicit
Option Compare Text

Sub SecondaryFilter_Contains30()
    Const filter_Column As Long = 2 ' 与原代码保持同一筛选列
    Const secondary_Criteria As String = "*30*"
    
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' 验证是否已执行第一次筛选
    If Not ws.AutoFilterMode Then
        MsgBox "当前未启用自动筛选，请先执行第一次过滤！", vbExclamation
        Exit Sub
    End If
    
    ' 定位与原代码一致的数据范围（排除表头）
    Dim rg As Range
    Set rg = ws.UsedRange.Resize(ws.UsedRange.Rows.Count - 1).Offset(1)
    
    ' 获取筛选列的可见单元格
    Dim visibleRg As Range
    On Error Resume Next
    Set visibleRg = rg.Columns(filter_Column).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If visibleRg Is Nothing Then
        MsgBox "当前无可见单元格，无法执行二次筛选！", vbExclamation
        Exit Sub
    End If
    
    ' 收集符合二次筛选条件的唯一值到Dictionary
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim cell As Range
    For Each cell In visibleRg
        If cell.Value Like secondary_Criteria Then
            dict(cell.Value) = vbNullString
        End If
    Next cell
    
    ' 应用二次筛选
    If dict.Count > 0 Then
        ws.AutoFilter.Range.AutoFilter Field:=filter_Column, Criteria1:=dict.Keys, Operator:=xlFilterValues
    Else
        MsgBox "未找到包含""30""的内容！", vbInformation
    End If
End Sub

关键逻辑说明 #

• 先校验工作表是否处于筛选状态，确保是第一次过滤后的结果
• 通过SpecialCells(xlCellTypeVisible)精准获取当前可见单元格范围
• 遍历可见单元格，用Dictionary去重收集符合*30*规则的内容
• 基于收集到的唯一值，对原筛选列应用二次自动筛选

内容的提问来源于stack exchange，提问作者Peace