按账户条件提取Excel工作表至新工作簿并保留公式格式的技术问询

嘿，我来帮你搞定这个按账户拆分Excel工作表的需求！你之前的初始代码还没对接上Accounts表的账户列表，我给你完善好完整的解决方案，一步步来：

核心处理逻辑 #

• 先从原工作簿的Accounts工作表读取所有需要处理的账户前缀（比如11-Greg）
• 针对每个账户，筛选出原工作簿中名称以该前缀开头的所有工作表
• 把这些工作表批量复制到新工作簿，完整保留公式、列宽、格式等设置
• 用账户名命名并保存新工作簿

完整可运行的VBA代码 #

Sub SplitWorkbooksByAccount()
    Dim sourceWB As Workbook
    Dim accountsWS As Worksheet
    Dim accountRange As Range
    Dim cell As Range
    Dim accountName As String
    Dim targetWB As Workbook
    Dim ws As Worksheet
    Dim savePath As String
    
    ' 指定源工作簿（就是当前运行代码的这个工作簿）
    Set sourceWB = ThisWorkbook
    ' 指向Accounts工作表
    Set accountsWS = sourceWB.Sheets("Accounts")
    
    ' 读取Accounts表的账户列表：假设账户在A列，从A2开始（A1是表头），可根据实际调整
    Set accountRange = accountsWS.Range("A2:A" & accountsWS.Cells(accountsWS.Rows.Count, "A").End(xlUp).Row)
    
    ' 让用户选择拆分后文件的保存路径（也可以改成固定路径，比如savePath = "C:\你的文件夹\"）
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择保存拆分后工作簿的文件夹"
        If .Show = -1 Then
            savePath = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择保存路径，程序退出。"
            Exit Sub
        End If
    End With
    
    ' 关闭屏幕刷新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 遍历Accounts表中的每个账户
    For Each cell In accountRange
        accountName = Trim(cell.Value)
        If accountName <> "" Then
            ' 先检查当前账户有没有对应的工作表
            Dim hasMatchingSheets As Boolean
            hasMatchingSheets = False
            
            For Each ws In sourceWB.Sheets
                ' 判断工作表名称是否以当前账户前缀开头（不区分大小写的话可以用StrComp函数）
                If Left(ws.Name, Len(accountName)) = accountName Then
                    hasMatchingSheets = True
                    Exit For
                End If
            Next ws
            
            If hasMatchingSheets Then
                ' 创建一个新的空白工作簿（只带一个默认工作表）
                Set targetWB = Workbooks.Add(xlWBATWorksheet)
                
                ' 复制所有符合当前账户的工作表到新工作簿
                For Each ws In sourceWB.Sheets
                    If Left(ws.Name, Len(accountName)) = accountName Then
                        ' 复制到新工作簿的最后，自动保留原表的格式、公式等
                        ws.Copy After:=targetWB.Sheets(targetWB.Sheets.Count)
                    End If
                Next ws
                
                ' 删除新工作簿默认的空白工作表（如果已经复制了至少一个表）
                If targetWB.Sheets.Count > 1 Then
                    Application.DisplayAlerts = False
                    targetWB.Sheets(1).Delete
                    Application.DisplayAlerts = True
                End If
                
                ' 保存新工作簿，捕获可能的错误（比如文件重名）
                On Error Resume Next
                targetWB.SaveAs Filename:=savePath & accountName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
                If Err.Number <> 0 Then
                    MsgBox "保存「" & accountName & "」时出错：" & Err.Description
                    Err.Clear
                End If
                On Error GoTo 0
                
                ' 关闭新工作簿
                targetWB.Close SaveChanges:=False
            End If
        End If
    Next cell
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "拆分完成！所有文件已保存到你选择的文件夹。"
End Sub

关键细节说明 #

• 账户列表范围调整：如果你的账户不在A列，或者不是从A2开始，修改accountRange里的列标识和起始行即可
• 固定保存路径：如果不想每次选文件夹，把文件夹选择的那段代码替换成savePath = "D:\你的目标文件夹\"（注意末尾加反斜杠）
• 大小写匹配：如果需要严格区分大小写，把判断前缀的代码改成If StrComp(Left(ws.Name, Len(accountName)), accountName, vbBinaryCompare) = 0 Then
• 格式保留：用ws.Copy方法复制工作表，会完整保留原表的公式、列宽、单元格格式、条件格式等所有设置

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