Copy variable number of tabs to multiple files

[weefisheads]

Been a minute since my last post...

I've found loads of macros that will create a new workbook for each tab in a source workbook - ie, a workbook with 25 tabs will be used to create 25 new workbooks, one for each tab. Lots of code for this out there.

What I'm looking for is that but with a wrinkle. Sometimes the source workbook will will have 1 tab for each newly created file, or it might need 2, or maybe 3 tabs that need to be copied to each individual workbook.

For example...the source workbook might have 2 tabs that need to be copied to the new file.
Tab 1 - Bill 1
Tab 2 - Bill 2
Tab 3 - Veronica 1
Tab 4 - Veronica 2
Tab 5 - Flloyd 1
Tab 6 - Flloyd 2

Running the macro I would hope to create 3 workbooks - Bill.xlsx, Veronica.xlsx, Flloyd.xlsx - and each new workbook would have 2 tabs.

Another month it might need to be 3 tabs from the source workbook. So

Tab 1 - Jessica 1
Tab 2 - Jessica 2
Tab 3 - Jessica 3
Tab 4 - Tim 1
Tab 5 - Tim 2
Tab 6 - Tim 3

Running the macro would create 2 new workbooks - Jessica.xlsx and Tim.xlsx - and each workbook will have 3 tabs.

One thing that is known is that there will always be the same number of tabs for all workbooks - so if there are 3 tabs for Bill, there will be 3 tabs for ALL names. But each time there maybe more or less names - might be 4, might be 20.

Hope I'm explaining it properly.

Thanks,

d

 

[Logit]

Option Explicit

Sub SplitTabsToWorkbooks()
    Dim ws As Worksheet
    Dim wbSource As Workbook
    Dim wbNew As Workbook
    Dim tabCount As Integer
    Dim i As Integer, j As Long
    Dim groupName As String

    ' Set the source workbook
    Set wbSource = ThisWorkbook

    ' Prompt the user for the number of tabs per group
    On Error Resume Next
    tabCount = Application.InputBox("Enter the number of tabs per group (e.g., 2 or 3):", Type:=1)
    On Error GoTo 0

    ' Validate the input
    If tabCount <= 0 Then
        MsgBox "Invalid input. Please enter a positive integer.", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False

    ' Loop through the sheets in groups of `tabCount`
    For i = 1 To wbSource.Sheets.Count Step tabCount
        ' Create a new workbook
        Set wbNew = Workbooks.Add

        ' Copy the group of tabs to the new workbook
        For j = 0 To tabCount - 1
            If i + j <= wbSource.Sheets.Count Then
                wbSource.Sheets(i + j).Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
            End If
        Next j

        ' Remove the default blank sheet in the new workbook
        Application.DisplayAlerts = False
        wbNew.Sheets(1).Delete
        Application.DisplayAlerts = True

        ' Determine the group name from the first tab in the group
        groupName = wbSource.Sheets(i).Name
        groupName = Left(groupName, InStrRev(groupName, " ") - 1)

        ' Save the new workbook
        wbNew.SaveAs Filename:=wbSource.Path & "\" & groupName & ".xlsx"
        wbNew.Close SaveChanges:=False
    Next i

    Application.ScreenUpdating = True

    MsgBox "Workbooks created successfully!", vbInformation
End Sub

 

[weefisheads]

Sorry to not reply sooner @Logit - holiday yesterday.

Tested the code - brilliant. Really amazing - absolutely speechless.

Ran this on 3 different files and on the last one it did error out because there was an odd number of sheets. I did say that if one file had 2 tabs per group then ALL would have 2 tabs per group, but one of the documents someone "missed" a tab. However, that was their error, and the fact that the macro errored out pointed me right to the culprit. Once I can get the 2nd tab created from that group then the code will be perfect.

Many thanks for such an elegant solution. What I would give to be able to code as cleanly and even a tenth as fast as you!

d

 

[Logit]

You are welcome.