Excel宏批量取消数组筛选报错求助：单元素正常多元素运行时错误

我之前在处理Excel筛选的VBA代码时也踩过这个坑——单元素取消筛选顺风顺水，一碰到3个及以上元素就报错，大概率是你处理多值筛选的逻辑没贴合Excel的筛选规则。下面给你拆解问题原因和修复方案：

问题根源 #

Excel的AutoFilter对多值筛选的数组格式有严格要求：

1. 当你要取消特定多个筛选值时，不能直接把这些值丢给Criteria1然后试图“取消”，而是需要重新构建筛选数组（保留不需要取消的项）；
2. 如果直接操作无筛选状态的列，或者错误判断筛选是否存在，也会触发运行时错误；
3. 多值筛选的Criteria1返回的是数组，单值时是字符串，两种情况要分开处理。

修复后的完整宏代码 #

下面是适配你需求的宏，包含“取消单元素筛选”和“取消多元素筛选”的正确逻辑，以及后续的复制粘贴步骤：

Sub ManageFiltersAndCopy()
    Dim wsOriginal As Worksheet
    Dim wsNew As Worksheet
    Dim filterCol As Integer
    
    ' 绑定原工作表（根据你的实际情况修改，比如Sheet1）
    Set wsOriginal = ThisWorkbook.Worksheets("Sheet1")
    
    ' --- 第一步：取消A列"COW"筛选并复制到新表 ---
    filterCol = 1 ' A列
    ' 检查是否有筛选，且目标列是否启用了筛选
    If wsOriginal.AutoFilterMode And wsOriginal.AutoFilter.Filters(filterCol).On Then
        ' 获取当前A列的筛选值
        Dim currentACriteria As Variant
        currentACriteria = wsOriginal.AutoFilter.Filters(filterCol).Criteria1
        
        ' 如果是单值筛选且等于"COW"，直接清除该列筛选
        If Not IsArray(currentACriteria) Then
            If currentACriteria = "COW" Then
                wsOriginal.AutoFilter.Range.AutoFilter Field:=filterCol
            End If
        Else
            ' 如果是多值筛选，移除"COW"后重新设置筛选
            Dim newACriteria As Variant
            Dim i As Integer, count As Integer
            count = 0
            
            ' 统计要保留的项数
            For i = LBound(currentACriteria) To UBound(currentACriteria)
                If currentACriteria(i) <> "COW" Then
                    count = count + 1
                End If
            Next i
            
            If count > 0 Then
                ReDim newACriteria(1 To count)
                count = 1
                For i = LBound(currentACriteria) To UBound(currentACriteria)
                    If currentACriteria(i) <> "COW" Then
                        newACriteria(count) = currentACriteria(i)
                        count = count + 1
                    End If
                Next i
                ' 重新设置筛选
                wsOriginal.AutoFilter.Range.AutoFilter Field:=filterCol, Criteria1:=newACriteria, Operator:=xlFilterValues
            Else
                ' 移除后没有筛选值，直接清除筛选
                wsOriginal.AutoFilter.Range.AutoFilter Field:=filterCol
            End If
        End If
    End If
    
    ' 复制到新工作表"Unfilter one item"
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets("Unfilter one item")
    On Error GoTo 0
    If wsNew Is Nothing Then
        Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsNew.Name = "Unfilter one item"
    End If
    wsOriginal.UsedRange.Copy Destination:=wsNew.Range("A1")
    
    ' --- 第二步：返回原表，清除旧筛选，取消H列多元素筛选 ---
    wsOriginal.Activate
    ' 清除所有旧筛选
    If wsOriginal.AutoFilterMode Then
        wsOriginal.AutoFilterMode = False
    End If
    
    ' 假设H列要取消筛选的元素是"Val1", "Val2", "Val3"（替换成你的实际值）
    Dim filterValsToRemove As Variant
    filterValsToRemove = Array("Val1", "Val2", "Val3")
    filterCol = 8 ' H列
    
    ' 先给H列设置初始筛选（模拟你的前置操作）
    wsOriginal.Range("H:H").AutoFilter Field:=filterCol, Criteria1:=filterValsToRemove, Operator:=xlFilterValues
    
    ' 现在取消这些多元素的筛选（即显示所有数据）
    ' 正确方式：直接清除该列的筛选
    If wsOriginal.AutoFilter.Filters(filterCol).On Then
        wsOriginal.AutoFilter.Range.AutoFilter Field:=filterCol
    End If
    
    ' 复制到新工作表（比如"Unfilter multiple items"）
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets("Unfilter multiple items")
    On Error GoTo 0
    If wsNew Is Nothing Then
        Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsNew.Name = "Unfilter multiple items"
    End If
    wsOriginal.UsedRange.Copy Destination:=wsNew.Range("A1")
End Sub

关键注意事项 #

• 先判断筛选状态：每次操作前都要检查AutoFilterMode和对应列的Filters(Col).On，避免在无筛选时执行操作报错；
• 区分单值/多值筛选：多值筛选的Criteria1是数组，单值是字符串，必须分开处理；
• 清除筛选的正确姿势：如果是要完全取消某列的筛选（显示所有数据），直接调用AutoFilter Field:=Col即可，不需要传入Criteria1；
• 处理新工作表的存在性：用On Error Resume Next判断工作表是否存在，避免重复创建报错。

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