如何基于Excel T列筛选值创建新工作表并粘贴数据？修复VBA报错

错误诱因分析 #

出现该错误主要源于以下几个问题：

• 直接通过List.Keys(i)访问字典键值在部分VBA环境中存在兼容性问题，Dictionary的Keys返回的是Variant数组，直接索引可能触发属性访问异常。
• 若T列唯一值包含工作表命名非法字符（如/ \ : * ? " < > |），执行destsheet.Name = List.Keys(i)时会抛出错误，中断后续流程。
• 循环中重复计算数据最后一行，可能因数据动态变化导致范围引用异常。
• 筛选后若仅存在表头（无匹配数据行），SpecialCells(xlCellTypeVisible)会触发无可见单元格的错误。

修正后的完整代码 #

Sub filtrer_copier_creeronglet()
    Dim Rng As Range, List As Object
    Dim i As Integer, lastrow As Long
    Dim destsheet As Worksheet, ws As Worksheet
    Dim keyArr As Variant ' 存储字典键值数组
    Dim validSheetName As String ' 处理后的合法工作表名

    ' 关闭屏幕刷新提升性能
    Application.ScreenUpdating = False

    ' 引用数据工作表
    Set ws = ThisWorkbook.Worksheets("donnees")
    ' 提前计算数据最后一行（列T）
    lastrow = ws.Cells(ws.Rows.Count, 20).End(xlUp).Row

    ' 创建字典存储唯一值
    Set List = CreateObject("Scripting.Dictionary")
    ' 遍历T列收集非空唯一值（跳过表头）
    For Each Rng In ws.Range("T2:T" & lastrow)
        If Not IsEmpty(Rng.Value) And Not List.Exists(Rng.Value) Then
            List.Add Rng.Value, Nothing
        End If
    Next Rng

    ' 将字典键值存入数组，避免直接索引的兼容性问题
    keyArr = List.Keys

    ' 遍历每个唯一值
    For i = LBound(keyArr) To UBound(keyArr)
        ' 处理工作表名称：替换非法字符为下划线，限制长度不超31位
        validSheetName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(keyArr(i), "/", "_"), "\", "_"), ":", "_"), "*", "_"), "?", "_"), """", "_"), "<", "_"), ">", "_"), "|", "_")
        validSheetName = Left(validSheetName, 31)

        ' 跳过空名称
        If validSheetName = "" Then GoTo NextIteration

        ' 检查工作表是否已存在，避免重复创建
        On Error Resume Next
        Set destsheet = ThisWorkbook.Worksheets(validSheetName)
        On Error GoTo 0
        ' 不存在则新建工作表
        If destsheet Is Nothing Then
            Set destsheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            destsheet.Name = validSheetName
        End If

        ' 清除目标表原有数据
        destsheet.Cells.Clear

        ' 应用筛选规则
        ws.Range("A1:T" & lastrow).AutoFilter Field:=20, Criteria1:=keyArr(i)

        ' 复制可见数据（含表头），捕获无数据的异常
        On Error Resume Next
        ws.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy destsheet.Range("A1")
        On Error GoTo 0

        ' 关闭筛选
        ws.AutoFilterMode = False
        ' 重置目标表变量
        Set destsheet = Nothing

NextIteration:
    Next i

    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "操作完成！", vbInformation
End Sub

关键优化说明 #

• 字典键值数组化：将List.Keys存入数组后通过LBound/UBound遍历，规避直接索引字典键值的兼容性问题。
• 合法名称处理：替换所有非法字符为下划线，限制名称长度，同时检查工作表是否已存在，避免重复创建。
• 错误捕获：对复制操作、工作表创建添加错误捕获，防止因无匹配数据或名称非法导致程序崩溃。
• 性能提升：提前计算数据最后一行，关闭屏幕刷新，减少冗余计算和界面闪烁。

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