Hi,
I have code that used to work beautifully until two days ago. It works on a workbook with multiple tabs - splits it into multiple workbooks from tab to tab with underscore _ in its name. E.g. I have a tab AT1_(AT stands for Atlantic) and three tabs after it - MD059 and PA199, then tab AT2_ and PA239, PA287, etc after it. It would make a new file AT1_ with all three tabs (AT1, MD059 and PA199) and save it to C:\temp. Then it would do the same with AT2_
Something happened and now it just saves AT1_ with no adjacent tabs. So I get a bunch of region tabs - AT1_, AT2_, NE1_, NE2_) - but no data tabs MDXXX, PAXXX, etc. in them.
I would do it all manually, but unfortunately, I have 64 regions + tabs in between. Makes it a pretty arduous task.
Again, the code below worked last month. I am not a programmer, just someone who can make sense of some code, maybe write something really simple and also plagiarize and combine snippents or code to make Excel do what I need. However, I cannot identify the problem here.
If you'd rather suggest a new code to split a workbook - please do. I can create a list of regions and tabs, something like that the code creates a book with all the AT tabs and then all the AT2 tabs, something like that. I imagine in any case the code will need a list with the worksheets.
At1_ MD059
AT1_ PA199
AT2_ PA239
AT2_ PA287
I cannot post attachments yet, so unfortunately cannot give you a test file. Basically if you create a file with multiple sheets and name a couple of them with XXXX_ and have some sheets with whatever names in between should do it.
Thank you so much for your help - combed internet and could not find anything to help me. Also planning to post this to Mr.Excel forum.
Lena
Sub SeparateWorksheetsByAVPRegion()
' The macro basically creates a list of all sheet names, then identifies the sheet number for all sheets considered to be the
' starting point of a new group. The default character is the underscore ("_") character. When the macro identifies an underscore,
' it selects that sheet and all sheets following that sheet until it reaches another sheet with an underscore in its name. It then saves
' that group of sheets as an Excel 97-2003 file named after the first sheet in the group, along with any suffix (entered by pop-up when
' the macro is launched). The files are saved into a time-stamped directory (by default, located in C:\temp, which can be changed below).
'
' Important note: The original file is altered. A sheet is added and calculations are performed in that sheet, but it
' is then deleted. The original file should therefore appear the same as it was before the macro was run. It is highly
' recommended that the original file be backed up prior to running the macro, however.
Dim Nsheet As Worksheet
Dim CustomSuffix As String
Dim WS As Worksheet
Dim rCount As Integer
Dim RegionalArray As Variant
Dim RegionalNames As Variant
Dim RegionsCount As Integer 'the number of regions can be changed below
Dim iCount As Integer
Dim Ctrs As Integer
Dim xCount As Integer
Dim iCountPick As Integer
Dim iCountCtrs As Integer
Dim wkSheetName As String
Dim xview As Variant
Dim xpathname As String, dtimestamp As String
Redim RegionalArray(1 To 450) ' this is the number of lines which will be scanned in the workbook (i.e.
Redim RegionalNames(1 To 450) ' this is the number of centers - can be GREATER than total # ctrs)
dtimestamp = Format(Now, "yyyymmdd_hhmmss") ' this is the timestamp for the folder
xpathname = "c:\temp\F" & dtimestamp & "\" ' you can change the default save path here
MkDir xpathname
RegionsCount = 4 'change the number of regions here
' ------------------------------------------------------------------------------------------------------
' This is the message box that prompts for a custom suffix to be attached to the created files
YesNo = MsgBox("Would you like to add a suffix to created files?" _
, vbYesNo + vbQuestion, "Add suffix?")
Select Case YesNo
Case vbYes
CustomSuffix = InputBox("Please enter your custom suffix which will be applied to all files created", _
"Custom Suffix", "")
End Select
' ------------------------------------------------------------------------------------------------------
'Create a sheet to figure out which sheets are "group" sheets and indicate the start of a new file
Application.ScreenUpdating = False
Set Nsheet = Sheets.Add
rCount = 1
For Each WS In Worksheets
If WS.Name <> Nsheet.Name Then
Nsheet.Range("A" & rCount) = WS.Name
rCount = rCount + 1
End If
Next WS
Nsheet.Name = "ALLSHEETNAMES"
Application.ScreenUpdating = True
' ------------------------------------------------------------------------------------------------------
'This section goes into Excel and uses a formula to identify which sheets begin a new group
Range("B1").Select
ActiveCell.FormulaR1C1 = "=ROW()"
Range("B1").Select
Selection.Copy
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Range("B999").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.End(xlUp).Select
Range("C1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""_"",RC[-2]))),RC[-1],"""")" ' this is where you can change the "_"
Range("C1").Select
Selection.Copy
Range("B1").Select
Selection.End(xlDown).Select
Range("C999").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Range("A1").Select
' ------------------------------------------------------------------------------------------------------
' Arrays are being built here
Ctrs = 1
For iCount = 1 To 999
If Range("C" & iCount) <> "" Then
RegionalArray(Ctrs) = Range("C" & iCount)
RegionalNames(Ctrs) = Range("A" & iCount)
Ctrs = Ctrs + 1
Else: Goto 0
0
End If
Next
' ------------------------------------------------------------------------------------------------------
' Use the created arrays to select worksheets, then copy them into a new workbook
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = False
For iCountCtrs = 1 To RegionsCount
ActiveWorkbook.Sheets(RegionalArray(iCountCtrs)).Select
wkSheetName = RegionalNames(iCountCtrs) & CustomSuffix
For iCountPick = RegionalArray(iCountCtrs) To RegionalArray(iCountCtrs + 1) - 1
ActiveWorkbook.Sheets(iCountPick).Select False
Application.ScreenUpdating = True
Next
ActiveWindow.SelectedSheets.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
Filename:=xpathname & wkSheetName & ".xls", _
FileFormat:=56, Password:="", _
WriteResPassword:="", CreateBackup:=False, _
ReadOnlyRecommended:=False
' the 56 listed above for the File Format is the Excel 97-2003 format
Application.DisplayAlerts = True
ActiveWindow.Close
Sheets(1).Select
Next
' ------------------------------------------------------------------------------------------------------
'Pop up to ask if the user would like to see the created files
YesNo = MsgBox("Would you like to open the folder to see" _
& vbCr & "the files which were created?", vbYesNo + vbQuestion, "Open Folder?")
Select Case YesNo
Case vbYes
xview = Shell("EXPLORER.EXE " & xpathname, vbNormalFocus)
Case vbNo
End Select
End Sub
I have code that used to work beautifully until two days ago. It works on a workbook with multiple tabs - splits it into multiple workbooks from tab to tab with underscore _ in its name. E.g. I have a tab AT1_(AT stands for Atlantic) and three tabs after it - MD059 and PA199, then tab AT2_ and PA239, PA287, etc after it. It would make a new file AT1_ with all three tabs (AT1, MD059 and PA199) and save it to C:\temp. Then it would do the same with AT2_
Something happened and now it just saves AT1_ with no adjacent tabs. So I get a bunch of region tabs - AT1_, AT2_, NE1_, NE2_) - but no data tabs MDXXX, PAXXX, etc. in them.
I would do it all manually, but unfortunately, I have 64 regions + tabs in between. Makes it a pretty arduous task.
Again, the code below worked last month. I am not a programmer, just someone who can make sense of some code, maybe write something really simple and also plagiarize and combine snippents or code to make Excel do what I need. However, I cannot identify the problem here.
If you'd rather suggest a new code to split a workbook - please do. I can create a list of regions and tabs, something like that the code creates a book with all the AT tabs and then all the AT2 tabs, something like that. I imagine in any case the code will need a list with the worksheets.
At1_ MD059
AT1_ PA199
AT2_ PA239
AT2_ PA287
I cannot post attachments yet, so unfortunately cannot give you a test file. Basically if you create a file with multiple sheets and name a couple of them with XXXX_ and have some sheets with whatever names in between should do it.
Thank you so much for your help - combed internet and could not find anything to help me. Also planning to post this to Mr.Excel forum.
Lena
Sub SeparateWorksheetsByAVPRegion()
' The macro basically creates a list of all sheet names, then identifies the sheet number for all sheets considered to be the
' starting point of a new group. The default character is the underscore ("_") character. When the macro identifies an underscore,
' it selects that sheet and all sheets following that sheet until it reaches another sheet with an underscore in its name. It then saves
' that group of sheets as an Excel 97-2003 file named after the first sheet in the group, along with any suffix (entered by pop-up when
' the macro is launched). The files are saved into a time-stamped directory (by default, located in C:\temp, which can be changed below).
'
' Important note: The original file is altered. A sheet is added and calculations are performed in that sheet, but it
' is then deleted. The original file should therefore appear the same as it was before the macro was run. It is highly
' recommended that the original file be backed up prior to running the macro, however.
Dim Nsheet As Worksheet
Dim CustomSuffix As String
Dim WS As Worksheet
Dim rCount As Integer
Dim RegionalArray As Variant
Dim RegionalNames As Variant
Dim RegionsCount As Integer 'the number of regions can be changed below
Dim iCount As Integer
Dim Ctrs As Integer
Dim xCount As Integer
Dim iCountPick As Integer
Dim iCountCtrs As Integer
Dim wkSheetName As String
Dim xview As Variant
Dim xpathname As String, dtimestamp As String
Redim RegionalArray(1 To 450) ' this is the number of lines which will be scanned in the workbook (i.e.
Redim RegionalNames(1 To 450) ' this is the number of centers - can be GREATER than total # ctrs)
dtimestamp = Format(Now, "yyyymmdd_hhmmss") ' this is the timestamp for the folder
xpathname = "c:\temp\F" & dtimestamp & "\" ' you can change the default save path here
MkDir xpathname
RegionsCount = 4 'change the number of regions here
' ------------------------------------------------------------------------------------------------------
' This is the message box that prompts for a custom suffix to be attached to the created files
YesNo = MsgBox("Would you like to add a suffix to created files?" _
, vbYesNo + vbQuestion, "Add suffix?")
Select Case YesNo
Case vbYes
CustomSuffix = InputBox("Please enter your custom suffix which will be applied to all files created", _
"Custom Suffix", "")
End Select
' ------------------------------------------------------------------------------------------------------
'Create a sheet to figure out which sheets are "group" sheets and indicate the start of a new file
Application.ScreenUpdating = False
Set Nsheet = Sheets.Add
rCount = 1
For Each WS In Worksheets
If WS.Name <> Nsheet.Name Then
Nsheet.Range("A" & rCount) = WS.Name
rCount = rCount + 1
End If
Next WS
Nsheet.Name = "ALLSHEETNAMES"
Application.ScreenUpdating = True
' ------------------------------------------------------------------------------------------------------
'This section goes into Excel and uses a formula to identify which sheets begin a new group
Range("B1").Select
ActiveCell.FormulaR1C1 = "=ROW()"
Range("B1").Select
Selection.Copy
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Range("B999").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.End(xlUp).Select
Range("C1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""_"",RC[-2]))),RC[-1],"""")" ' this is where you can change the "_"
Range("C1").Select
Selection.Copy
Range("B1").Select
Selection.End(xlDown).Select
Range("C999").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Range("A1").Select
' ------------------------------------------------------------------------------------------------------
' Arrays are being built here
Ctrs = 1
For iCount = 1 To 999
If Range("C" & iCount) <> "" Then
RegionalArray(Ctrs) = Range("C" & iCount)
RegionalNames(Ctrs) = Range("A" & iCount)
Ctrs = Ctrs + 1
Else: Goto 0
0
End If
Next
' ------------------------------------------------------------------------------------------------------
' Use the created arrays to select worksheets, then copy them into a new workbook
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = False
For iCountCtrs = 1 To RegionsCount
ActiveWorkbook.Sheets(RegionalArray(iCountCtrs)).Select
wkSheetName = RegionalNames(iCountCtrs) & CustomSuffix
For iCountPick = RegionalArray(iCountCtrs) To RegionalArray(iCountCtrs + 1) - 1
ActiveWorkbook.Sheets(iCountPick).Select False
Application.ScreenUpdating = True
Next
ActiveWindow.SelectedSheets.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs _
Filename:=xpathname & wkSheetName & ".xls", _
FileFormat:=56, Password:="", _
WriteResPassword:="", CreateBackup:=False, _
ReadOnlyRecommended:=False
' the 56 listed above for the File Format is the Excel 97-2003 format
Application.DisplayAlerts = True
ActiveWindow.Close
Sheets(1).Select
Next
' ------------------------------------------------------------------------------------------------------
'Pop up to ask if the user would like to see the created files
YesNo = MsgBox("Would you like to open the folder to see" _
& vbCr & "the files which were created?", vbYesNo + vbQuestion, "Open Folder?")
Select Case YesNo
Case vbYes
xview = Shell("EXPLORER.EXE " & xpathname, vbNormalFocus)
Case vbNo
End Select
End Sub
