本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 SubErrorHandler: ' 显示错误信息 MsgBox "发生错误: " & Err.Description, vbCritical ' 清理对象引用 Set uniqueValues = Nothing Set dict = Nothing Set wsSource = Nothing Set wsNew = Nothing Set wb = NothingEnd Sub运行说明Alt+F11打开VBA编辑器，插入新的模块，并把代码粘贴进右侧代码区确保源工作表为活动工作表（包含需要拆分的数据）。运行宏（F5或通过Excel的宏菜单）。在弹出的输入框中输入用于拆分的列标题（需与表头完全匹配）。每个唯一值对应的数据将生成在以唯一值命名的新工作表中。注意事项列标题需与工作表第一行的表头完全匹配（大小写敏感，建议检查空格）。工作表名称会根据唯一值生成，非法字符（如 /, , :, *, ?, [, ]）会被替换为下划线，长度限制在31个字符以内。如果唯一值生成的工作表名称重复，代码会自动添加编号以区分。建议备份数据以防意外数据丢失。代码假设数据从第2行开始（第1行为表头），如有不同结构，请调整代码逻辑。
配资好评股票配资门户提示：文章来自网络，不代表本站观点。
