VBA Code that extracts multiple tabs at a time based on lookup tab

[SWahl]

I have a workbook with 70 tabs to be extracted, some individually but most in groupings. Ultimately, I need to send each senior director a workbook with a tab for each of their departments ("Cost Centers"). Each tab name represents the cost center name.

For example, John Doe oversees Accounts Payable, Accounts Receivable, and Procurement. I need to extract those three tabs from my master file and copy them to a new file named "John Doe - 2025 AOP Budgeting".

I have a source/lookup tab named "Cost Centers" which lists all cost centers (which also represent each sheet name) in column C and the senior director in column D.

I am looking for a VBA code that will create a file for each senior director and their associated cost centers.

Hopefully this is clear enough, but let me know if more info is needed!


For extra credit, I would love a macro that would then draft an email to send each senior director a copy of the file, based on a template email. The corresponding emails would be listed in column E of the "Cost Centers" tab.

 

[NoSparks]

I am not trying to create new sheets for the directors, simply just want to copy each director's associated sheets to a new workbook.

For example, Sr Director 1 would have one workbook with 6 sheets in there representing each cost center.

Perhaps something along the lines of this is what you're after.
It creates and saves the 6 workbooks to a Temp folder on my D drive so you would need to change that to wherever you would be using then email it.

Sub CopySheets()
    
    Dim wsSource As Worksheet
    Dim lastRow As Long, i As Long, cel As Range
    Dim ShtDict As Object, ShtArr As Variant
    
    ' establish source of info
    Set wsSource = ThisWorkbook.Sheets("Cost Centers")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row
    
    ' load the dictionary
    Set ShtDict = CreateObject("Scripting.Dictionary")
    For Each cel In wsSource.Range("D2:D" & lastRow)
        If Not ShtDict.exists(cel.Value) Then
            ShtDict.Add cel.Value, cel.Offset(, -2).Value
        Else
            ShtDict(cel.Value) = ShtDict(cel.Value) & "," & cel.Offset(, -2).Value
        End If
    Next cel
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    On Error GoTo OOPs
    
    ' sheet copy requirement for each director
    For i = 0 To ShtDict.Count - 1
        ' add a workbook with specific sheets
        ShtArr = Split(ShtDict.items()(i), ",")
        ThisWorkbook.Sheets(ShtArr).Copy
        ' save this workbook
        With ActiveWorkbook
            Application.DisplayAlerts = False
            .SaveAs "D:\Temp\" & ShtDict.keys()(i), FileFormat:=51
            .Close savechanges:=True
            Application.DisplayAlerts = True
        End With
    Next i
    
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "Done"
    Exit Sub
    
OOPs:
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "A problem was encountered"
End Sub