如何用VBA按规则批量复制工作表到对应新工作簿

核心逻辑 #

1. 遍历原工作簿所有工作表，提取每个表名的前缀（以-为分隔符取第一部分）
2. 对前缀去重，得到需要创建的新工作簿名称列表
3. 逐个为每个前缀创建新工作簿，将所有匹配该前缀的工作表复制到新工作簿中
4. 自动保存新工作簿到原工作簿所在路径

VBA代码实现 #

Sub SplitSheetsByPrefix()
    Dim srcWB As Workbook
    Dim destWB As Workbook
    Dim ws As Worksheet
    Dim prefix As String
    Dim prefixDict As Object
    Dim savePath As String
    
    ' 设置源工作簿为当前运行代码的工作簿
    Set srcWB = ThisWorkbook
    ' 获取源工作簿的保存路径
    savePath = srcWB.Path & "\"
    ' 创建字典存储唯一前缀
    Set prefixDict = CreateObject("Scripting.Dictionary")
    
    ' 第一步：提取所有工作表的前缀并去重
    For Each ws In srcWB.Worksheets
        ' 以"-"为分隔符提取前缀
        prefix = Split(ws.Name, "-")(0)
        ' 如果字典里没有这个前缀就添加进去
        If Not prefixDict.Exists(prefix) Then
            prefixDict.Add prefix, ""
        End If
    Next ws
    
    ' 第二步：逐个前缀创建新工作簿并复制对应工作表
    For Each prefix In prefixDict.Keys
        ' 创建新工作簿（仅含一个空白工作表）
        Set destWB = Workbooks.Add(xlWBATWorksheet)
        ' 遍历源工作簿所有工作表，匹配前缀就复制
        For Each ws In srcWB.Worksheets
            If Split(ws.Name, "-")(0) = prefix Then
                ' 复制工作表到新工作簿末尾
                ws.Copy After:=destWB.Sheets(destWB.Sheets.Count)
            End If
        Next ws
        ' 删除新工作簿默认的空白工作表（仅当复制了目标表时执行）
        If destWB.Sheets.Count > 1 Then
            Application.DisplayAlerts = False ' 关闭删除提示弹窗
            destWB.Sheets(1).Delete
            Application.DisplayAlerts = True
        End If
        ' 保存新工作簿，文件名使用前缀
        destWB.SaveAs Filename:=savePath & prefix & ".xlsx"
        ' 关闭新工作簿
        destWB.Close SaveChanges:=False
    Next prefix
    
    MsgBox "拆分完成！新工作簿已保存到原文件所在路径。"
End Sub

使用步骤 #

1. 打开需要拆分的原工作簿
2. 按下Alt + F11打开VBA编辑器
3. 右键点击左侧工程窗口中的当前工作簿，选择「插入」→「模块」
4. 将上述代码粘贴到模块窗口中
5. 按下F5运行代码，或点击编辑器工具栏的运行按钮

注意事项 #

• 原工作簿需提前保存（否则无法获取保存路径）
• 新工作簿会覆盖同路径下的同名文件，运行前请确认目标路径无重名文件
• 若代码报错提示找不到Scripting.Dictionary，可在VBA编辑器中选择「工具」→「引用」，勾选「Microsoft Scripting Runtime」

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