Split Workbook into separate workbooks with a copy of original sheets in each and a sheet with a single condition split

[rsur]

Hi all,

I have an excel workbook ("Master") that has multiple worksheets - two worksheets ("Overview" and "Tip Sheet") have info explaining what the workbooks are about, a third ("Datasheet") has the data for all departments, and finally worksheets for each department. I need to split the Master workbook into separate workbooks for each department that I can share with them. I tried to accomplish this using the VBA code -

Sub SplitbyService()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Overview" And ws.Name <> "Tip Sheet" And ws.Name <> "Datasheet" Then
ws.Copy
Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
End If

Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

However, these resulting workbooks ("New") all have a single sheet with the a department's data. I want each of the "New" workbooks to also contain both the "Overview" and "Tip Sheet" sheets as separate sheets (So a total of 3 sheets in each "New" workbook). Can someone please help me with this?

 

[John_w]

Try this macro:

Public Sub Create_Department_Workbooks()

    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False 'suppress warning if file already exists
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Overview" And ws.Name <> "Tip Sheet" And ws.Name <> "Datasheet" Then
            Worksheets(Array("Overview", "Tip Sheet", ws.Name)).Copy
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close False
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

 

[rsur]

Thanks John! That worked like a charm. Appreciate your help.

 

[rsur]

I have a follow-up question. The current code saves the new file name as - ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook.

How can I add current date (Date function) to each files name? Thanks for your help!

 

[rsur]

I have a follow-up question. The current code saves the new file name as - ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook.

How can I add current date (Date function) to each files name? Thanks for your help!

Done. Was able to do it using Format(Date, "mm.dd.yyyy")