按列内容拆分Excel工作表为多子表及独立.xlsx文件需求

因为你熟悉VBA，以下VBA宏方案能一次性完成拆分+导出，完全适配你每月重复处理的需求，处理1500条记录和60个名称毫无压力。

步骤1：使用VBA宏实现自动拆分与导出 #

代码实现 #

打开你的Excel文件，按Alt+F11打开VBA编辑器，右键点击当前工作簿 → 插入 → 模块，粘贴以下代码：

Sub SplitAndExportSheets()
    Dim wsSource As Worksheet
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim nameCol As Integer
    Dim uniqueNames As Collection
    Dim i As Long
    Dim currentName As String
    Dim savePath As String
    
    ' 配置参数：修改为你的原始工作表名称和姓名列序号（A=1, B=2...）
    Set wsSource = ThisWorkbook.Worksheets("原始数据") ' 替换成你的源表名
    nameCol = 2 ' 假设姓名在B列，按需修改
    savePath = ThisWorkbook.Path & "\拆分结果\" ' 导出文件保存到当前工作簿同目录的"拆分结果"文件夹
    
    ' 创建保存目录（如果不存在）
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    ' 收集所有唯一姓名
    Set uniqueNames = New Collection
    On Error Resume Next ' 忽略重复项报错
    lastRow = wsSource.Cells(wsSource.Rows.Count, nameCol).End(xlUp).Row
    For i = 2 To lastRow ' 假设第1行是表头，从第2行开始遍历
        currentName = wsSource.Cells(i, nameCol).Value
        If currentName <> "" Then
            uniqueNames.Add currentName, Key:=CStr(currentName)
        End If
    Next i
    On Error GoTo 0
    
    ' 遍历每个姓名，创建工作表并导出
    For Each currentName In uniqueNames
        ' 检查是否已存在同名工作表，存在则删除
        On Error Resume Next
        Set wsNew = ThisWorkbook.Worksheets(currentName)
        If Err.Number = 0 Then
            Application.DisplayAlerts = False
            wsNew.Delete
            Application.DisplayAlerts = True
        End If
        On Error GoTo 0
        
        ' 新建工作表并命名
        Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsNew.Name = currentName
        
        ' 复制表头到新表
        wsSource.Rows(1).Copy Destination:=wsNew.Rows(1)
        
        ' 筛选源表数据并复制到新表
        wsSource.Range("A1").AutoFilter Field:=nameCol, Criteria1:=currentName
        wsSource.Range("A1:" & wsSource.Cells(lastRow, wsSource.Columns.Count).Address).SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wsNew.Range("A1")
        
        ' 取消源表筛选
        wsSource.AutoFilterMode = False
        
        ' 导出新表为独立xlsx文件
        wsNew.SaveAs Filename:=savePath & currentName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        
        ' 可选：如果不需要保留拆分后的工作表，取消下面两行注释
        'Application.DisplayAlerts = False
        'wsNew.Delete
        'Application.DisplayAlerts = True
    Next currentName
    
    MsgBox "拆分与导出完成！文件已保存至：" & savePath, vbInformation
End Sub

使用说明 #

1. 修改代码开头的配置参数：
   • wsSource：替换成你的原始数据工作表名称（比如"Sheet1"）
   • nameCol：姓名列的序号（A列是1，B列是2，以此类推）
   • savePath：可以自定义导出文件的保存路径
2. 按F5运行宏，或者回到Excel界面，通过「开发工具」→「宏」选择SplitAndExportSheets执行
3. 执行完成后，所有以姓名命名的独立xlsx文件会保存在指定文件夹中

步骤2：优化重复使用效率 #

如果你每月都要处理这类文件，可以把这个宏保存到个人宏工作簿（Personal.xlsb）：

• 打开VBA编辑器，将模块复制到Personal.xlsb中
• 之后任何Excel文件都可以直接调用这个宏，无需重复粘贴代码

替代方案：Power Query（无需代码） #

如果你不想用VBA，也可以用Excel内置的Power Query实现拆分：

1. 选中数据区域 → 「数据」→「从表格/区域」导入Power Query编辑器
2. 点击「姓名」列标题 → 「转换」→「分组依据」，选择「高级」，添加分组操作：所有行，命名为「数据」
3. 点击「数据」列的展开按钮 → 「到工作表」，Excel会自动为每个姓名创建独立工作表
4. 批量导出工作表：可以用「开发工具」→「宏」写简单的导出代码，或者手动逐个保存（手动仅适合少量名称，宏更高效）

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