将特定单元格中具有相同值的所有工作表抽取到新工作簿中

Question

我有一个包含300多个选项卡的文件，用于每个员工的销售佣金。其中一些员工由2-6名员工组成。团队名称在每个选项卡上，即使它是一个团队，也在单元格AA3中。我想要VBA代码将AA3（团队名称）与名为“团队”& $ AA $ 3的新文件相同的所有工作表提取出来。

我有一个宏提取每个工作表到一个新的文件，但我无法弄清楚如何正确编写循环来做我想问的问题。

的代码我有每片提取到一个新的文件如下：

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

斯科特的建议的后续行动，这里有一个函数，将返回所有的唯一值的工作簿中，对于给定单元格地址。它利用了Collection对象，并且只能为其添加唯一值。例如，第二次尝试添加“A队”将跳过它（ON错误语句中）：

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