如何用VBA按Excel A列值筛选并批量创建对应命名工作表粘贴数据

参考样例 #

• 源数据表示例
  
• CC命名新工作表示例
  
• DD命名新工作表示例
  

修改后的完整代码 #

Sub SplitSheetByColumnA()
    Dim src As Worksheet
    Dim tgt As Worksheet
    Dim filterRange As Range
    Dim copyRange As Range
    Dim lastRow As Long
    Dim uniqueCol As Object
    Dim cell As Range
    Dim key As Variant
    
    ' 初始化源工作表，清除原有筛选
    Set src = ThisWorkbook.Sheets("Sheet1")
    src.AutoFilterMode = False
    ' 读取A列最后一行行号
    lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
    Set filterRange = src.Range("A1:A" & lastRow)
    ' 可根据实际数据列数修改下方P为对应最后一列列标
    Set copyRange = src.Range("A1:P" & lastRow)
    
    ' 用字典存储A列所有非空唯一值（自动跳过表头和重复值）
    Set uniqueCol = CreateObject("Scripting.Dictionary")
    For Each cell In src.Range("A2:A" & lastRow)
        If Not uniqueCol.exists(cell.Value) And cell.Value <> "" Then
            uniqueCol.Add cell.Value, cell.Value
        End If
    Next cell
    
    ' 遍历所有唯一值完成拆分
    For Each key In uniqueCol.keys
        ' 校验是否已存在同名工作表，避免报错
        On Error Resume Next
        Set tgt = ThisWorkbook.Sheets(CStr(key))
        If Err.Number <> 0 Then
            Set tgt = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            tgt.Name = CStr(key)
        End If
        On Error GoTo 0
        
        ' 清空目标表原有内容
        tgt.Cells.Clear
        
        ' 按当前唯一值筛选源表
        filterRange.AutoFilter Field:=1, Criteria1:=CStr(key)
        ' 复制可见内容到目标表首行
        copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
    Next key
    
    ' 处理完成后关闭源表筛选
    src.AutoFilterMode = False
    MsgBox "拆分完成，共生成" & uniqueCol.Count & "个工作表"
End Sub

调整说明 #

• 新增字典对象自动提取A列所有非空唯一值，不需要手动指定筛选条件
• 新增工作表存在性校验逻辑，避免重复创建同名工作表报错
• 全流程自动遍历处理所有唯一值，直到A列最后一个值为止
• 如果A列存在Excel工作表命名不支持的特殊字符（/\?*[]等），可自行在字典取值环节增加字符替换逻辑避免命名报错

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