Combine common worksheet names when splitting a file

Refreshing a persistent issue. I am using the below formula to split each excel tab into it's own workbook, and that works great. The issue is I utilize Month, YTD and Full Year tabs for each recipients distribution; in my case they are broken out by name, so for example it would read "John Smith", "John Smith (2)" and "John Smith (3)" less the quotations for MTD, YTD and Full Year respectively. What I would like to do is combine each person's 3 worksheets onto one workbook. It appears there are two methods to do this:
1) Use a certain number of characters for it then all like names will be converted to one workbook (i.e. 8 characters would be "John Smi" which would capture all 3 but may fail with two people named Gregory).
2) Using a code that excludes numbers and special characters (i.e. John Smith (3) = John Smith) - here i'm also unsure if the space after the name would cause an issue. This option is more ideal for dealing with both very long first names and very short first + last names.

Any thoughts or insight would be greatly appreciated, as I am currently splitting my file with the below formula and the manually copying three workbooks together. Doing this 70 times each month is a burden. End goal is having one workbook for each common name with a Month, YTD and Full Year tab (bonus would be including a data tab at the end based off of the full year tab).

Sub Splitbook()
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Why do you need separate tabs/workbooks. In my experience it is better to hold all of the data together with the defining attributes (name, date, amount etc). and then use some analysis tool to view whatever you want to vies.

Code:

---

Sub test()
    Dim dic As Object
    Dim ws As Worksheet
    Dim s As String
   
    Set dic = CreateObject("scripting.dictionary")
   
    For Each ws In Worksheets
        s = ws.name
        If s Like "* (?)" Then
            dic(Left(s, Len(s) - 4)) = True
        End If
    Next
   
    MsgBox Join(dic.keys, vbLf)
   
End Sub

---

Quote:

---

The issue is I utilize Month, YTD and Full Year tabs for each recipients distribution; in my case they are broken out by name, so for example it would read "John Smith", "John Smith (2)" and "John Smith (3)" less the quotations for MTD, YTD and Full Year respectively.

---

So... Does that mean the "John Smith" is actually the Full Year report/tab?
"John Smith", "John Smith (MTD)" and "John Smith (YTD)"
Or
"John Smith", "John Smith(MTD)" and "John Smith(YTD)"
Or
"John Smith", "John Smith MTD" and "John Smith YTD"



I soooo much dislike spreadsheet designers that don't use proper patterns. It makes life so complicated. :banghead::banghead::banghead:

I'm just gonna a save this here in case I decide to come back to it.

Code:

---

Option Base 1

Sub SplitReportsIntoNewBooks()
'This assumes that all sheets with the same Client Name are next to each other
'This assumes that there is no spaces(s) between a Client Name and the Open
'  Parentheses around the Report Category
Dim Clientname As String
Dim Category As String
Dim Extension As String
Dim List As Variant
Dim Tmp As Variant
Dim WkSht As Worksheet
Dim ShtName As String
Dim SINW As Long
Dim i As Long

Extension = ".xlsx"
ReDim List(Worksheets.Count, 3)

With Application
  SINW = .SheetsInNewWorkbook
  .SheetsInNewWorkbook = 3
  .EnableEvents = False
  .DisplayAlerts = False
End With

For i = 1 To Worksheets.Count
  Tmp = Split(Worksheets(i).Name, "(") 'Will Error on "John Smith"
  ShtName = Tmp(1)
  Category = Left(Tmp(2), 3)

'Make new book
'Add Sheets i + 1 + 2 increment i
'rename sheets
'Save and close

Next i


With Application
  .SheetsInNewWorkbook = SINW
  .EnableEvents = True
  .DisplayAlerts = True
End With

---

You have a number of assumptions about WS names, etc.

Code:

---

Option Explicit


Sub SplitWorkbook()
    Dim sNames As String, sName As String
    Dim ws As Worksheet
    Dim aryNames As Variant
    Dim wbName As Workbook
    Dim iName As Long
   
    Application.ScreenUpdating = False
   
    'build string of WS names that do NOT end with a )
    For Each ws In Worksheets
        If Right(ws.Name, 1) <> ")" Then
            sNames = sNames & ws.Name & ";"
        End If
    Next
       
    If Right(sNames, 1) = ";" Then sNames = Left(sNames, Len(sNames) - 1)
   
    'put WS base names into array
    aryNames = Split(sNames, ";")
   
   
    For i = LBound(aryNames) To UBound(aryNames)
       
        'copy base WS to make new WB
        Worksheets(aryNames(i)).Copy
        Set wbName = ActiveWorkbook
       
        'add the (2) and (3) WS to new WB
        ThisWorkbook.Worksheets(aryNames(i) & " (2)").Copy After:=wbName.Sheets(1)
        ThisWorkbook.Worksheets(aryNames(i) & " (3)").Copy After:=wbName.Sheets(2)


        'build the new WB name = this path + base name
        sName = ThisWorkbook.Path & Application.PathSeparator & aryNames(i) & ".xlsx"
       
        'delete if it exists
        Application.DisplayAlerts = False
        On Error Resume Next
        Kill sName
        On Error GoTo 0
        Application.DisplayAlerts = True


        'save new WB and close
        wbName.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & aryNames(i) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
   
        ActiveWindow.Close
    Next i


    Application.ScreenUpdating = True


    MsgBox "Done"


End Sub

---

My crystal ball tells me the next thing will be VBA to email each WB to the designated person

Quote:

---

Originally Posted by xld

Why do you need separate tabs/workbooks. In my experience it is better to hold all of the data together with the defining attributes (name, date, amount etc). and then use some analysis tool to view whatever you want to vies.

---

The data is all held together and shown on their data tabs, what I am doing is creating three separate pivot tables to give quick and easy views for the recipients (these are people with very, very limited excel knowledge so they won't even know how to use the basic report filters).

It means that "John Smith" is MTD, "John Smith (2)" is YTD and "John Smith (3)" is Full Year, I just leave MTD as the recipients name for ease and manually change the 2nd and third tab names to "YTD" and "Full Year" and double-click the total on the Full Year tab to create a data tab - End result is 4 tabs (John Smith [MTD tab], YTD, Full Year, and Data). Unfortunately the output of the files will automatically be the name as I add name to the report filters to separate the Pivot Table into separate worksheets, but that's fine. Yeah it came up with an error but I think it's on the right track. The tab names that repeat are separate, as the original file will be the same format as the end file (just not broken out), so excel outputs names A-Z for MTD, then YTD, then Full Year. There is also a space that excel enters prior to the Open Parenthesis. I appreciate you lookinig into it!

This worked perfectly Paul! A wizard indeed, thank you so much! I cannot state the dread it was manually combining these three files 70 times every single month. It seemed to handle the name length issue just fine as well. I really appeciate the help!

Quote:

---

Originally Posted by Paul_Hossler

You have a number of assumptions about WS names, etc.

Code:

---

Option Explicit


Sub SplitWorkbook()
    Dim sNames As String, sName As String
    Dim ws As Worksheet
    Dim aryNames As Variant
    Dim wbName As Workbook
    Dim iName As Long
   
    Application.ScreenUpdating = False
   
    'build string of WS names that do NOT end with a )
    For Each ws In Worksheets
        If Right(ws.Name, 1) <> ")" Then
            sNames = sNames & ws.Name & ";"
        End If
    Next
       
    If Right(sNames, 1) = ";" Then sNames = Left(sNames, Len(sNames) - 1)
   
    'put WS base names into array
    aryNames = Split(sNames, ";")
   
   
    For i = LBound(aryNames) To UBound(aryNames)
       
        'copy base WS to make new WB
        Worksheets(aryNames(i)).Copy
        Set wbName = ActiveWorkbook
       
        'add the (2) and (3) WS to new WB
        ThisWorkbook.Worksheets(aryNames(i) & " (2)").Copy After:=wbName.Sheets(1)
        ThisWorkbook.Worksheets(aryNames(i) & " (3)").Copy After:=wbName.Sheets(2)


        'build the new WB name = this path + base name
        sName = ThisWorkbook.Path & Application.PathSeparator & aryNames(i) & ".xlsx"
       
        'delete if it exists
        Application.DisplayAlerts = False
        On Error Resume Next
        Kill sName
        On Error GoTo 0
        Application.DisplayAlerts = True


        'save new WB and close
        wbName.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & aryNames(i) & ".xlsx", FileFormat:=xlOpenXMLWorkbook
   
        ActiveWindow.Close
    Next i


    Application.ScreenUpdating = True


    MsgBox "Done"


End Sub

---

My crystal ball tells me the next thing will be VBA to email each WB to the designated person

---