基于分支名称列表实现VBA循环拆分并保存Excel数据求助

你当前的代码手动处理两个分支，改成循环版本的核心是遍历Branch_List工作表里的所有分支名称，同时优化掉代码里大量的Select/Activate操作（这类操作会降低代码稳定性和执行效率）。

下面是修改后的完整代码：

Sub Due_Sheet()
    Dim mainWB As Workbook
    Dim dataWS As Worksheet
    Dim branchWS As Worksheet
    Dim branchRange As Range
    Dim branchCell As Range
    Dim savePath As String
    Dim newWB As Workbook
    
    ' 定义文件保存路径
    savePath = "C:\Users\hp\Desktop\@ARMAN_MSME_MACRO\"
    
    ' 打开主工作簿并引用目标工作表
    Set mainWB = Workbooks.Open(savePath & "All Products Due List May'24.xlsx")
    Set dataWS = mainWB.Sheets("Due May-24")
    Set branchWS = mainWB.Sheets("Branch_List")
    
    ' 动态获取Branch_List中B列的所有分支名称（从B3开始到最后一个非空单元格）
    Set branchRange = branchWS.Range("B3", branchWS.Cells(branchWS.Rows.Count, "B").End(xlUp))
    
    ' 开启数据工作表的自动筛选
    dataWS.Range("A1").AutoFilter
    
    ' 循环处理每个分支
    For Each branchCell In branchRange
        Dim branchName As String
        branchName = branchCell.Value
        
        ' 跳过空单元格
        If branchName <> "" Then
            ' 写入分支名称到Branch_List（保留原代码的逻辑）
            branchCell.Value = branchName
            
            ' 按分支名称筛选数据（第2列为分支列）
            dataWS.Range("$A$1:$AK$1000000").AutoFilter Field:=2, Criteria1:=branchName
            
            ' 复制筛选后的可见数据
            dataWS.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
            
            ' 创建新工作簿并粘贴数据
            Set newWB = Workbooks.Add
            newWB.Sheets(1).Range("A1").PasteSpecial xlPasteAll
            
            ' 清除复制模式
            Application.CutCopyMode = False
            
            ' 设置单元格格式并自动调整列宽
            With newWB.Sheets(1).UsedRange
                .HorizontalAlignment = xlLeft
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
                .Columns.AutoFit
            End With
            
            ' 写入分支名称到B2（保留原代码的逻辑）
            newWB.Sheets(1).Range("B2").Value = branchName
            
            ' 保存新工作簿
            newWB.SaveAs Filename:=savePath & branchName & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            
            ' 关闭新工作簿
            newWB.Close SaveChanges:=False
        End If
    Next branchCell
    
    ' 清除原工作簿的筛选状态
    dataWS.AutoFilterMode = False
    
    ' 关闭原工作簿，不保存更改
    mainWB.Close SaveChanges:=False
    
    ' 释放对象，避免内存占用
    Set mainWB = Nothing
    Set dataWS = Nothing
    Set branchWS = Nothing
    Set newWB = Nothing
End Sub

关键优化说明 #

• 移除Select/Activate：直接通过对象引用操作工作表和单元格，代码更稳定、执行速度更快
• 动态分支列表：自动识别Branch_List中所有非空分支名称，无需手动指定分支数量
• 循环批量处理：用For Each循环遍历所有分支，不管分支数量多少都能自动处理
• 精准复制数据：仅复制筛选后的可见单元格，避免复制无效空行
• 对象资源释放：最后释放所有定义的对象，避免内存泄漏

注意事项 #

1. 确保Branch_List工作表的B列从B3开始为有效分支名称，空单元格会被自动跳过
2. 确认保存路径savePath对应的文件夹存在，否则会触发保存错误
3. 若分支名称包含/:*?"<>|等特殊字符，需额外处理后再保存，否则会导致文件保存失败

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