将具有相同值的所有工作表抽取到新的工作簿中

我有一个文件，每个员工的销售佣金超过300个标签。 有些员工是由2-6名员工组成的。 团队名称在每个选项卡上，即使它是一个团队，也在单元格AA3中。 我想用VBA代码将AA3（团队名称）相同的所有工作表抽取到一个名为“团队”和$ AA $ 3的新文件。

我有一个macros提取每个表到一个新的文件，但我不知道如何正确地编写循环做我所问。

我有这样的代码提取每个工作表到一个新的文件如下：

Sub Copy_Every_Sheet_To_New_Workbook_2() 'Working in 97-2010 Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim Destwb As Workbook Dim sh As Worksheet Dim DateString As String Dim FolderName As String Dim TEAM As String Dim Team2 As String With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With 'Copy every sheet from the workbook with this macro Set Sourcewb = ThisWorkbook 'Create new folder to save the new files in DateString = Format(Now, "yyyy-mm-dd hh-mm-ss") FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString MkDir FolderName 'Copy every visible sheet to a new workbook For Each sh In Sourcewb.Worksheets 'If the sheet is visible then copy it to a new workbook If sh.Visible = -1 Then sh.Copy 'Set Destwb to the new workbook Set Destwb = ActiveWorkbook 'Determine the Excel version and file extension/format With Destwb If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007-2010 If Sourcewb.Name = .Name Then MsgBox "Your answer is NO in the security dialog" GoTo GoToNextSheet Else Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If .HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If End If End With 'Change all cells in the worksheet to values if you want If Destwb.Sheets(1).ProtectContents = False Then With Destwb.Sheets(1).UsedRange .Cells.Copy .Cells.PasteSpecial xlPasteValues .Cells(1).Select End With Application.CutCopyMode = False End If 'Save the new workbook and close it With Destwb .SaveAs FolderName & "\" & Destwb.Sheets(1).Range("AK2").Value & FileExtStr, _ FileFormat:=FileFormatNum .Close False End With End If GoToNextSheet: Next sh MsgBox "You can find the files in " & FolderName With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub 

Answer 1

跟随斯科特的build议，这里是一个函数，将返回工作簿中的所有唯一值，对于给定的单元格地址。 它利用了Collection对象，并且只能为其添加唯一值。 例如，第二次尝试添加“Team A”时，会跳过它（在On Error语句中）：

 Function GetUniqueCellValues(wb As Excel.Workbook, cellAddress As String) As Collection Dim ws As Excel.Worksheet Dim coll As Collection Set coll = New Collection For Each ws In wb.Worksheets On Error Resume Next coll.Add ws.Range(cellAddress).Value, ws.Range(cellAddress).Text On Error GoTo 0 Next ws Set GetUniqueCellValues = coll End Function 

我喜欢尝试编写函数，以使它们依赖于工作簿中的内容，或者其他方法，而不是对列表进行硬编码。

如果您想在工作簿中包含代码的所有工作表的单元格AA3 （即ThisWorkbook每个唯一值，则可以这样调用它：

 Sub test() Dim collTeamNames As Collection Dim i As Long Set collTeamNames = GetUniqueCellValues(ThisWorkbook, "AA3") For i = 1 To collTeamNames.Count Debug.Print collTeamNames(i) 'do your processing here Next i End Sub