如何将基于列的多个工作表中的数据拆分为 Excel 中的多个工作簿？

Question

对这些论坛中提出的 2 个热门问题略有改动...

我正在尝试根据不同的列值将 Excel 工作簿拆分为多个工作簿（我们称它们为 saleTeam1、saleTeam2、saleTeam3）。

但是，主题工作簿有多个工作表，每个工作表报告不同销售团队的不同指标：工作表之间唯一的共同点是销售团队，在每个工作表的第一列中都有说明。

我将 2 个 VBA 宏用于不同的其他任务：

1）根据A列中的唯一值将目标工作表解析为多个工作表，以及

2) 拆分工作簿并为每个独特的工作表创建新工作簿。

尝试将这两个功能集成在一起，但我觉得从头开始构建它可能更值得。但是，我无法找到一个有效的解决方案。

    Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

'set split target column
vcol = 1

' set split target sheet
Set ws = Sheets("Sheet1")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:M1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Sub SplitWB()
Dim xlApp As Object
Dim wbSource As Object
Dim wbNew As Object
Dim ws As Worksheet
Dim strFileName As String

    ' change path and filename here
    strFileName = "C:\Users\username\Documents\split\split.xlsx"

    Set xlApp = CreateObject("Excel.Application")

    Set wbSource = xlApp.Workbooks.Open(strFileName)

    For Each ws In wbSource.Worksheets
         ws.Copy
         Set wbNew = xlApp.ActiveWorkbook
         wbNew.SaveAs wbSource.Path & xlApp.PathSeparator & ws.Name & ".xlsx"
         wbNew.Close
         Set wbNew = Nothing
    Next ws

    wbSource.Close SaveChanges:=False
    Set wbSource = Nothing

    xlApp.Quit
    Set xlApp = Nothing

End Sub

底线：尝试将包含 6 个团队数据的 1 个工作簿（包含 5 个不同列的工作表）分成 6 个工作簿（每个工作簿与原始工作簿具有相同的 5 个工作表），每个团队的数据都是分开的

Answer 1

我不喜欢将你的两个函数分组的想法，我更喜欢先让团队使用字典，然后为每个团队创建一个 WB 并使用 Excel 的过滤功能。试试这样：

Sub SplitWB()
    Application.EnableEvents = False: Application.ScreenUpdating = False: Application.DisplayAlerts = True
    On Error GoTo Cleanup

    Dim ws As Worksheet, wb As Workbook, team
    For Each team In getTeams
        Set wb = Workbooks.Add ' create a wb for each team with same # of sheets
        Do Until wb.Worksheets.count >= ThisWorkbook.Worksheets.count
            wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.count)
        Loop

        For Each ws In ThisWorkbook.Worksheets
            With ws.UsedRange
                .AutoFilter 1, team ' filter to copy only the team's rows
                .Copy wb.Sheets(ws.Index).Range("A1")
                .AutoFilter
            End With
            wb.Sheets(ws.Index).name = ws.name & "_" & team
        Next
        wb.SaveAs ThisWorkbook.path & "\" & team & ".xlsx"
        wb.Close False
    Next

Cleanup:
    Application.EnableEvents = True: Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

Function getTeams() ' gets the unique team names using a dictionary
    Dim cel As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Sheets("Sheet1")
        For Each cel In .Range("A2:A" & .Cells(.Rows.count, "A").End(xlUp).row)
            If Len(Trim(cel.Value2)) > 0 Then dict(cel.Value2) = 0
        Next
    End With
    getTeams = dict.Keys
End Function