VBA-Excel 按某字段拆分为多个表

拆分Excel表格的需求

• 通常按某个字段进行拆分明细, 约定默认 "A列"
• 要保留Excel 的原始格式, 并将最终结果存在当前路径下, 明细_时间戳 里面
• 要支持10w以上 的数据量

我原来的方式就是用 Python 的 Pandas 库来整一个脚本, 这个效率很高, 但是保留原始的 excel 格式有点麻烦.

于是想了一下, 不妨直接用 Excel 中的 VBA 程序处理一下即可, 然后代码直接用 AI 生成即可, 这里只是作为一个记录, 因为使用非常高频, 方便复制粘贴.

Sub 按A列字段拆分表格()
    ' ==============================================================
    ' 高性能版本：适用于 >10万行数据
    ' - 使用 AutoFilter 筛选 + 可见区域复制（保留全部格式）
    ' - 自动创建 "拆分明细_时间戳" 文件夹
    ' - 每个文件保存为：A列值-后缀.xlsx
    ' ==============================================================
    
    Dim wsData As Worksheet
    Dim LastRow As Long, LastCol As Long
    Dim rngData As Range
    Dim key As Variant
    Dim uniqueKeys As Object
    Dim i As Long
    
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim basePath As String
    Dim folderName As String
    Dim savePath As String
    Dim fileName As String
    Dim userSuffix As String
    
    ' 性能关键设置
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
        .CutCopyMode = False
    End With
    
    On Error GoTo ErrorHandler
    
    ' ================= 配置区 =================
    Set wsData = ThisWorkbook.Sheets(1)  ' 可修改为指定名称
    ' =========================================
    
    ' 获取用户后缀
    userSuffix = InputBox("请输入文件名后缀（如：xxx明细）：" & vbCrLf & _
                          "文件将命名为：A列值-后缀.xlsx", "输入文件名后缀")
    If userSuffix = "" Or StrPtr(userSuffix) = 0 Then
        MsgBox "操作已取消。", vbInformation
        GoTo ExitSub
    End If
    
    ' 获取数据范围（假设第1行为标题）
    LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    LastCol = wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
    
    If LastRow < 2 Then
        MsgBox "数据无效：至少需要标题行和一行数据！", vbExclamation
        GoTo ExitSub
    End If
    
    Set rngData = wsData.Range(wsData.Cells(1, 1), wsData.Cells(LastRow, LastCol))
    
    ' 收集 A 列唯一非空值（跳过标题）
    Set uniqueKeys = CreateObject("Scripting.Dictionary")
    uniqueKeys.CompareMode = vbTextCompare
    
    For i = 2 To LastRow
        key = wsData.Cells(i, 1).Value
        If Not IsEmpty(key) And key <> "" Then
            uniqueKeys(CStr(key)) = Empty
        End If
    Next i
    
    If uniqueKeys.Count = 0 Then
        MsgBox "A 列无有效数据可用于拆分！", vbExclamation
        GoTo ExitSub
    End If
    
    ' 创建带时间戳的文件夹
    basePath = ThisWorkbook.Path
    If basePath = "" Then
        MsgBox "请先保存当前工作簿！", vbCritical
        GoTo ExitSub
    End If
    
    folderName = "拆分明细_" & Format(Now, "yyyymmdd_hhmmss")
    savePath = basePath & "\" & folderName & "\"
    
    ' 创建文件夹（Dir 不存在则 MkDir）
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    ' 添加临时筛选（避免影响原表，最后清除）
    If wsData.AutoFilterMode Then wsData.AutoFilterMode = False
    rngData.AutoFilter  ' 启用筛选
    
    Dim keyItem As Variant
    Dim visibleCount As Long
    
    For Each keyItem In uniqueKeys.Keys
        key = keyItem
        
        ' 清除之前筛选
        rngData.AutoFilter
        
        ' 按 A 列筛选当前 key
        rngData.AutoFilter Field:=1, Criteria1:=key
        
        ' 检查是否有可见数据行（除标题外）
        On Error Resume Next
        visibleCount = wsData.Range(wsData.Cells(2, 1), wsData.Cells(LastRow, 1)).SpecialCells(xlCellTypeVisible).Count
        On Error GoTo 0
        
        If visibleCount = 0 Then GoTo NextKey
        
        ' 新建工作簿
        Set newWb = Workbooks.Add
        Set newWs = newWb.Sheets(1)
        newWs.Name = "Data"
        
        ' 复制标题 + 筛选结果（含全部格式）
        rngData.SpecialCells(xlCellTypeVisible).Copy
        newWs.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
        Application.CutCopyMode = False
        
        ' 自动调整列宽（可选，若想完全一致可注释掉）
        ' newWs.Columns.AutoFit
        
        ' 生成安全文件名
        fileName = CleanFileName(CStr(key)) & "-" & CleanFileName(userSuffix) & ".xlsx"
        Dim fullPath As String
        fullPath = savePath & fileName
        
        ' 保存（覆盖旧文件）
        If Dir(fullPath) <> "" Then Kill fullPath
        newWb.SaveAs fileName:=fullPath, FileFormat:=xlOpenXMLWorkbook
        newWb.Close SaveChanges:=False
        
NextKey:
    Next keyItem
    
    ' 清除筛选
    wsData.AutoFilterMode = False
    
    MsgBox "Okk, 拆分完成！共生成 " & uniqueKeys.Count & " 个文件。" & vbCrLf & _
           "保存路径：" & savePath, vbInformation

ExitSub:
    ' 恢复 Excel 设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
        .CutCopyMode = False
    End With
    Exit Sub

ErrorHandler:
    wsData.AutoFilterMode = False ' 确保清除筛选
    MsgBox "错误：" & Err.Description & " (错误号: " & Err.Number & ")", vbCritical
    Resume ExitSub
End Sub


' --------------------------------------------------------------
' 清理非法文件名字符
' --------------------------------------------------------------
Function CleanFileName(fileName As String) As String
    Dim invalidChars As String: invalidChars = "\/:*?""<>|"
    Dim i As Integer
    For i = 1 To Len(invalidChars)
        fileName = Replace(fileName, Mid(invalidChars, i, 1), "_")
    Next i
    fileName = Replace(fileName, Chr(10), "")
    fileName = Replace(fileName, Chr(13), "")
    fileName = Trim(fileName)
    If Right(fileName, 1) = "." Then fileName = Left(fileName, Len(fileName) - 1)
    If fileName = "" Then fileName = "未命名"
    CleanFileName = Left(fileName, 50)
End Function

使用过程

首先要开启宏功能, 不能是 Excel 还是 Wps 这个在设置里面找找配置就好了.

第 0 步:

然后按住 Alt+F11 打开内置的 VBA 编辑器窗口, 插入-模块, 将代码贴到右侧里面

第 1 步:

第 2 步:

第 3 步:

这样就搞定了, 所有代码都是 AI 弄的, 这里只是整理为一个笔记而已, 拿走不谢!