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

在这些论坛中，有两个流行问题被问到，这是一个小小的转折

我正在尝试根据不同的列值将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

子解析_数据（）
变暗lr为长
将ws设置为工作表
Dim vcol，i作为整数
如长
Dim myarr作为变异体
将标题设置为字符串
作为整数的Dim titlerow
'设置拆分目标列
vcol=1
'设置分割目标表
设置ws=图纸（“图纸1”）
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）=“唯一”
对于i=2至lr
出错时继续下一步
如果ws.Cells（i，vcol）“”和Application.WorksheetFunction.Match（ws.Cells（i，vcol），ws.Columns（icol），0）=0，则
ws.Cells（ws.Rows.Count，icol）.End（xlUp）.Offset（1）=ws.Cells（i，vcol）
如果结束
下一个
myarr=Application.WorksheetFunction.Transpose（ws.Columns（icol）.SpecialCells（xlCellTypeConstants））
ws.Columns（icol）.清除
对于i=2至UBound（myarr）
ws.Range（title）.AutoFilter字段：=vcol，标准1:=myarr（i）&“”
如果不进行评估（“=ISREF（”&myarr（i）&“！A1）”），则
Sheets.Add（之后：=工作表（Worksheets.Count））.Name=myarr（i）和“”
其他的
工作表（myarr（i）和“”）。移动后：=工作表（Worksheets.Count）
如果结束
ws.Range（“A”&标题栏&“：A”&标题栏）.EntireRow.Copy图纸（myarr（i）&“）.Range（“A1”）
图纸（myarr（i）和“”）.Columns.AutoFit
下一个
ws.AutoFilterMode=False
ws.Activate
端接头
子拆分wb（）
将xlApp作为对象
将源作为对象
将新对象设置为对象
将ws设置为工作表
将strFileName设置为字符串
'在此处更改路径和文件名
strFileName=“C:\Users\username\Documents\split\split.xlsx”
设置xlApp=CreateObject（“Excel.Application”）
设置wbSource=xlApp.Workbooks.Open（strFileName）
对于wbSource.worksheet中的每个ws
ws.Copy
设置wbNew=xlApp.active工作簿
wbNew.SaveAs wbSource.Path&xlApp.pathselector&ws.Name&“.xlsx”
新的，结束
设置wbNew=Nothing
下一个ws
wbSource.Close SaveChanges:=False
设置wbSource=Nothing
xlApp.退出
设置xlApp=Nothing
端接头

---

一句话：试图将一个包含6个团队数据的工作簿（包含5个不同列的工作表）制作成6个工作簿（每个工作簿与原始工作簿具有相同的5个工作表），每个团队的数据分开

我不喜欢将两个功能分组的想法，我更喜欢先让团队使用字典，然后为每个团队创建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