VBA遍历Autofilter条件异常及筛选复制脚本问题求助

先聊聊你的问题根源：原来的脚本没处理好Autofilter的条件遍历逻辑，还误取消了I列的选中状态，再加上空行的存在，导致工作表命名时出现无效字符或者空名称的问题。下面是完全贴合你需求的修正后代码：

Sub FilterAndCopyAllCriteria()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim filterCol As Integer
    Dim filterRange As Range
    Dim uniqueCriteria As Variant
    Dim i As Integer
    Dim lastRow As Long
    Dim visibleData As Range
    
    ' 指定源工作表（这里默认是当前活动表，你可以改成具体表名比如Sheets("数据源")）
    Set wsSource = ActiveSheet
    filterCol = 9 ' I列对应的列号
    
    ' 确保源表开启自动筛选，没有的话就打开
    If Not wsSource.AutoFilterMode Then
        wsSource.Range("A1").AutoFilter
    End If
    
    ' 获取I列所有非空的唯一筛选条件（跳过表头）
    With wsSource
        lastRow = .Cells(.Rows.Count, filterCol).End(xlUp).Row
        Set filterRange = .Range(.Cells(2, filterCol), .Cells(lastRow, filterCol))
        uniqueCriteria = GetUniqueNonBlankValues(filterRange)
    End With
    
    ' 遍历每个筛选条件
    For i = LBound(uniqueCriteria) To UBound(uniqueCriteria)
        ' 应用当前筛选条件到I列
        wsSource.Range("A1").AutoFilter Field:=filterCol, Criteria1:=uniqueCriteria(i)
        
        ' 获取筛选后的可见数据（包含表头）
        On Error Resume Next
        Set visibleData = wsSource.UsedRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        ' 跳过空结果的情况
        If Not visibleData Is Nothing Then
            ' 创建新工作表
            Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            
            ' 处理工作表命名：清洗无效字符，避免异常
            Dim sheetName As String
            sheetName = Trim(uniqueCriteria(i))
            ' 替换Excel不允许的命名字符
            sheetName = Replace(sheetName, "/", "-")
            sheetName = Replace(sheetName, "\", "-")
            sheetName = Replace(sheetName, ":", "-")
            sheetName = Replace(sheetName, "*", "-")
            sheetName = Replace(sheetName, "?", "-")
            sheetName = Replace(sheetName, "[", "-")
            sheetName = Replace(sheetName, "]", "-")
            ' 处理空名称的情况
            If sheetName = "" Then
                sheetName = "筛选结果_" & i
            End If
            ' 名称长度限制在31字符内（Excel工作表名上限）
            If Len(sheetName) > 31 Then
                sheetName = Left(sheetName, 31)
            End If
            wsNew.Name = sheetName
            
            ' 把可见数据复制到新表
            visibleData.Copy Destination:=wsNew.Range("A1")
        End If
        
        ' 释放对象，避免内存占用
        Set visibleData = Nothing
    Next i
    
    ' 关闭自动筛选，恢复源表状态
    wsSource.AutoFilterMode = False
    
    MsgBox "所有筛选条件处理完成！", vbInformation
End Sub

' 辅助函数：提取指定区域的非空唯一值
Function GetUniqueNonBlankValues(rng As Range) As Variant
    Dim cell As Range
    Dim uniqueDict As Object
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    For Each cell In rng
        If Not IsEmpty(cell.Value) And cell.Value <> "" Then
            If Not uniqueDict.Exists(cell.Value) Then
                uniqueDict.Add cell.Value, cell.Value
            End If
        End If
    Next cell
    
    If uniqueDict.Count > 0 Then
        GetUniqueNonBlankValues = uniqueDict.Keys
    Else
        GetUniqueNonBlankValues = Array()
    End If
End Function

关键修正点说明： #

1. 自动遍历筛选条件：通过辅助函数GetUniqueNonBlankValues自动提取I列所有非空唯一值，不用手动指定任何条件，全程自动遍历。
2. 避免取消选中状态：不再操作单元格选中状态，直接用SpecialCells(xlCellTypeVisible)获取可见数据，完全不干扰原表的选中状态。
3. 解决命名异常：对筛选条件文本做了清洗，替换掉Excel不允许的命名字符，同时处理空名称、过长名称的情况，彻底避免命名报错。
4. 跳过空结果：筛选后先检查是否有有效可见数据，空结果直接跳过，不会创建空工作表。

你可以直接把这段代码复制到VBA编辑器里运行，记得先保存好你的工作簿哦！

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