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

2个受欢迎的问题，在这些论坛上被问到轻微的扭曲…

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

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

我使用2个VBAmacros来执行其他任务：

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

2）拆分工作簿并为每个唯一的工作表创build新的工作簿。

试图将2个function集成在一起，但是我觉得从零开始构build它可能更有价值。 然而，我无法围绕一个有效的解决scheme。

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个团队数据将6个工作簿（每个工作簿与原始工作簿相同的5个工作表）与1个工作簿（包含5个工作表，带有不同的列）分开，每个团队的数据分开

Answer 1

我不喜欢将两个函数分组的想法，我更愿意先使用字典获得团队，然后为每个团队创build一个WB，并使用Excel的过滤function。 试试像这样：

 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