基于分支代码拆分数据至独立工作簿的VBA代码修改需求

我完全懂你的需求——原来的代码是在同一个工作簿里给每个分支代码新建工作表，但你需要改成每个分支对应生成一个独立的Excel工作簿，还得用分支代码给工作簿命名。另外你提到对Resize方法不太熟悉，我会在代码里加详细注释帮你理解它的作用。

先简单说下Resize：这个方法就是用来调整单元格区域的范围，语法是Range.Resize(行数, 列数)。比如原代码里的.Cells(p, 1).Resize(i - p, cls)，意思是从第p行第1列的单元格开始，选中i-p行（当前分支的所有数据行数）、cls列（原表的总列数）的区域，也就是这个分支对应的所有数据。

修改后的完整代码（带注释） #

Sub ColumnToWorkbooks()
    Const sname As String = "Sheet1" ' 源数据所在工作表名称，可根据实际修改
    Const s As String = "A" ' 分支代码所在列，可根据实际修改
    Const savePath As String = "C:\Users\34389\Documents\test\" ' 工作簿保存路径，务必修改为你的本地路径！
    
    Dim d As Object, a, cc&
    Dim p&, i&, rws&, cls&
    Dim sourceWs As Worksheet
    Dim newWb As Workbook
    Dim branchName As String
    
    ' 创建字典用于记录已处理过的分支代码，避免重复生成工作簿
    Set d = CreateObject("scripting.dictionary")
    Set sourceWs = ThisWorkbook.Sheets(sname)
    
    ' 获取源数据的总行数和总列数
    With sourceWs
        rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        cc = .Columns(s).Column ' 获取分支代码列的列号
    End With
    
    ' 先把所有已存在的工作表名称存入字典（原逻辑保留，避免命名冲突）
    For Each sh In ThisWorkbook.Worksheets
        d(sh.Name) = 1
    Next sh
    
    Application.ScreenUpdating = False ' 关闭屏幕刷新，提升运行速度
    Application.DisplayAlerts = False ' 关闭系统提示框，避免运行被中断
    
    ' 新建临时工作表用于排序源数据（让相同分支的数据集中在一起，方便分组）
    With Sheets.Add(after:=sourceWs)
        ' 复制源数据到临时表
        sourceWs.Cells(1).Resize(rws, cls).Copy .Cells(1)
        ' 按分支代码列排序，升序排列
        .Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
        ' 把分支代码列的数据存入数组，提升遍历效率
        a = .Cells(cc).Resize(rws + 1, 1).Value
        
        p = 2 ' 标记当前分支的起始行（从第2行开始，因为第1行是表头）
        For i = 2 To rws + 1
            ' 当遇到不同的分支代码，或者遍历到最后一行时，处理当前分支
            If a(i, 1) <> a(p, 1) Or i = rws + 1 Then
                branchName = a(p, 1)
                ' 如果这个分支还没处理过
                If d(branchName) <> 1 Then
                    ' 新建一个空白工作簿
                    Set newWb = Workbooks.Add
                    ' 复制源数据的表头到新工作簿的首行
                    sourceWs.Cells(1).Resize(1, cls).Copy newWb.Sheets(1).Cells(1)
                    ' 复制当前分支的所有数据到新工作簿的第2行开始的位置
                    ' Resize(i-p, cls)：i-p是当前分支的数据行数，cls是原表的总列数
                    .Cells(p, 1).Resize(i - p, cls).Copy newWb.Sheets(1).Cells(2, 1)
                    
                    ' 清理文件名：移除Windows不允许的非法字符，避免保存失败
                    branchName = CleanFileName(branchName)
                    ' 保存新工作簿，用分支代码作为文件名
                    newWb.SaveAs Filename:=savePath & branchName & ".xlsx"
                    ' 关闭新工作簿
                    newWb.Close
                    ' 把已处理的分支存入字典，避免重复生成
                    d(branchName) = 1
                End If
                p = i ' 更新下一个分支的起始行标记
            End If
        Next i
        
        ' 删除临时工作表
        .Delete
    End With
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ' 激活源工作表，方便后续操作
    sourceWs.Activate
    MsgBox "所有工作簿已生成完成！", vbInformation
End Sub

' 辅助函数：清理文件名中的非法字符
Function CleanFileName(strName As String) As String
    Dim invalidChars As Variant
    Dim char As Variant
    ' Windows文件名禁止使用的字符列表
    invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    For Each char In invalidChars
        strName = Replace(strName, char, "")
    Next char
    ' 限制文件名长度不超过255字符（Windows系统限制）
    CleanFileName = Left(strName, 255)
End Function

关键修改说明 #

• 替换新建逻辑：用Workbooks.Add创建独立工作簿，代替原代码的Sheets.Add（创建工作表）
• 数据复制优化：先复制表头到新工作簿，再用Resize精准选中当前分支的所有数据行进行复制
• 文件名处理：新增CleanFileName函数，自动移除文件名中的非法字符（比如/、:），避免保存失败
• 流畅性优化：关闭屏幕刷新和系统提示框，让代码运行更快更顺畅；添加完成提示，方便你确认任务结束

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