本VBA代码旨在基于用户指定的列标题，将Excel工作表中的数据按该列的唯一值拆分到单独的工作表中。代码通过用户输入的列标题识别拆分依据，收集唯一值，并为每个唯一值创建新的工作表，将对应数据复制过去，同时保留原始表头。代码包含详细注释，便于理解和修改，适合需要按特定字段分类Excel数据的场景。运行前，请确保源工作表具有有效的数据和正确的表头，且列标题输入需与表头完全匹配。

Sub SplitDataByColumn()
    ' 声明变量
    Dim wb As Workbook          ' 当前工作簿对象
    Dim wsSource As Worksheet   ' 源数据工作表
    Dim wsNew As Worksheet      ' 新建的工作表
    Dim dataArray As Variant    ' 存储源数据的数组
    Dim lastRow As Long         ' 最后一行号
    Dim lastCol As Long         ' 最后一列号
    Dim colHeader As String     ' 用户输入的列标题
    Dim colIndex As Long        ' 拆分依据的列索引
    Dim uniqueValues As Object  ' 字典对象，存储唯一值
    Dim dict As Object          ' 字典对象，用于检查工作表名称是否重复
    Dim i As Long               ' 循环计数器
    Dim j As Long               ' 循环计数器
    Dim newSheetName As String  ' 新工作表名称
    Dim validHeader As Boolean  ' 验证列标题是否有效
    Dim outputArray As Variant  ' 存储每个唯一值对应数据的数组
    Dim outputRowCount As Long  ' 输出数组的行数
    Dim uniqueVal As Variant    ' 唯一值循环变量
    
    ' 设置错误处理
    On Error GoTo ErrorHandler
    
    ' 初始化当前工作簿和源工作表
    Set wb = ThisWorkbook
    Set wsSource = wb.ActiveSheet
    
    ' 获取用户输入的列标题
    colHeader = InputBox("请输入用于拆分的列标题（需与表头完全匹配）：", "输入列标题")
    If colHeader = "" Then
        MsgBox "未输入列标题，操作已取消。", vbExclamation
        Exit Sub
    End If
    
    ' 找到最后一列和最后一行
    lastCol = wsSource.Cells(1, Columns.Count).End(xlToLeft).Column
    lastRow = wsSource.Cells(Rows.Count, 1).End(xlUp).Row
    
    ' 检查输入的列标题是否存在
    validHeader = False
    For i = 1 To lastCol
        If Trim(wsSource.Cells(1, i).Value) = Trim(colHeader) Then
            colIndex = i
            validHeader = True
            Exit For
        End If
    Next i
    
    ' 如果列标题无效，提示并退出
    If Not validHeader Then
        MsgBox "未找到标题为 '" & colHeader & "' 的列，请检查输入！", vbCritical
        Exit Sub
    End If
    
    ' 将源数据读入数组以提高处理速度
    dataArray = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, lastCol)).Value
    
    ' 初始化唯一值字典
    Set uniqueValues = CreateObject("Scripting.Dictionary")
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 收集指定列的唯一值（从第2行开始，跳过表头）
    For i = 2 To lastRow
        If Not IsEmpty(dataArray(i, colIndex)) Then
            If Not uniqueValues.Exists(CStr(dataArray(i, colIndex))) Then
                uniqueValues.Add CStr(dataArray(i, colIndex)), True
            End If
        End If
    Next i
    
    ' 如果没有唯一值，提示并退出
    If uniqueValues.Count = 0 Then
        MsgBox "指定列中没有有效数据可拆分！", vbExclamation
        Exit Sub
    End If
    
    ' 遍历唯一值，创建新工作表并复制数据
    For Each uniqueVal In uniqueValues.Keys
        ' 生成工作表名称（限制长度并处理非法字符）
        newSheetName = Left(Replace(CStr(uniqueVal), "/", "_"), 31)
        newSheetName = Replace(newSheetName, "\", "_")
        newSheetName = Replace(newSheetName, ":", "_")
        newSheetName = Replace(newSheetName, "*", "_")
        newSheetName = Replace(newSheetName, "?", "_")
        newSheetName = Replace(newSheetName, "[", "_")
        newSheetName = Replace(newSheetName, "]", "_")
        
        ' 检查工作表名称是否重复，若重复则添加编号
        If dict.Exists(newSheetName) Then
            Dim suffix As Integer
            suffix = 1
            Do While dict.Exists(newSheetName & "_" & suffix)
                suffix = suffix + 1
            Loop
            newSheetName = newSheetName & "_" & suffix
        End If
        dict.Add newSheetName, True
        
        ' 创建新工作表
        Set wsNew = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        wsNew.Name = newSheetName
        
        ' 复制表头到新工作表
        wsNew.Range(wsNew.Cells(1, 1), wsNew.Cells(1, lastCol)).Value = Application.Index(dataArray, 1, 0)
        
        ' 统计匹配唯一值的行数
        outputRowCount = 0
        For i = 2 To lastRow
            If CStr(dataArray(i, colIndex)) = CStr(uniqueVal) Then
                outputRowCount = outputRowCount + 1
            End If
        Next i
        
        ' 初始化输出数组（包括表头）
        ReDim outputArray(1 To outputRowCount, 1 To lastCol)
        
        ' 填充输出数组
        Dim outputRow As Long
        outputRow = 1
        For i = 2 To lastRow
            If CStr(dataArray(i, colIndex)) = CStr(uniqueVal) Then
                For j = 1 To lastCol
                    outputArray(outputRow, j) = dataArray(i, j)
                Next j
                outputRow = outputRow + 1
            End If
        Next i
        
        ' 将输出数组写入新工作表（从第2行开始）
        wsNew.Range("A2").Resize(outputRowCount, lastCol).Value = outputArray
        
        ' 自动调整新工作表列宽
        wsNew.Columns.AutoFit
    Next uniqueVal
    
    ' 显示完成消息
    MsgBox uniqueValues.Count & " 个唯一值的数据已拆分到单独工作表。", vbInformation
    
    ' 清理对象引用
    Set uniqueValues = Nothing
    Set dict = Nothing
    Set wsSource = Nothing
    Set wsNew = Nothing
    Set wb = Nothing
    Exit Sub

ErrorHandler:
    ' 显示错误信息
    MsgBox "发生错误: " & Err.Description, vbCritical
    ' 清理对象引用
    Set uniqueValues = Nothing
    Set dict = Nothing
    Set wsSource = Nothing
    Set wsNew = Nothing
    Set wb = Nothing
End Sub

运行说明

1. Alt+F11打开VBA编辑器，插入新的模块，并把代码粘贴进右侧代码区
2. 确保源工作表为活动工作表（包含需要拆分的数据）。
3. 运行宏（F5或通过Excel的宏菜单）。
4. 在弹出的输入框中输入用于拆分的列标题（需与表头完全匹配）。
5. 每个唯一值对应的数据将生成在以唯一值命名的新工作表中。

注意事项

• 列标题需与工作表第一行的表头完全匹配（大小写敏感，建议检查空格）。
• 工作表名称会根据唯一值生成，非法字符（如 /, , :, *, ?, [, ]）会被替换为下划线，长度限制在31个字符以内。
• 如果唯一值生成的工作表名称重复，代码会自动添加编号以区分。
• 建议备份数据以防意外数据丢失。
• 代码假设数据从第2行开始（第1行为表头），如有不同结构，请调整代码逻辑。