Combine common worksheet names when splitting a file

[CharlieP]

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

[Bob Phillips]

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.

[mana]

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

[SamT]

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.
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

[Paul_Hossler]

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




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

[CharlieP]

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).

[CharlieP]

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!

[CharlieP]

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!


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




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