Save Multiple Worksheets as New Workbooks Based on Sheet Prefixes

I have a macro that I use to generate new workbooks based off of the existing worksheet names.

So, if a worksheet is named "10", a new workbook will be generated named "10.xlsx".

However, if I have two sheets named "10[something1]" and "10[something2]", is there a way to get both of those tabs pushed into a new workbook named "10[something]"

Essentially, the macro should be able to run through all sheets in the workbook named similary as the examples above, and perform the same save functionality.

The code that I have below is what I am currently using to perform the single worksheet to workbook save, but would really appreciate some help on performing the aforementioned:

Sub BSplitbook()
'Updateby20140612
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" 'you can change path and file type here
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Thanks in advance

Hi hamidxa

What do your Actual Sheet Names look like?

Originally Posted by jaslake

Hi hamidxa

What do your Actual Sheet Names look like?

jaslake

They would all have a 2 digit prefix followed by some name

Real examples include:
10Transition, 10Moved, 10Same
11Transition, 11Moved, 11Same
12Transition, 12Moved, 12Same
etc.

If there would be a way to save all of the 10-based prefix sheets as a workbook simply named "10.xlsx", or all of the 11-based prefix sheets as "11.xlsx", etc., then that would be perfect.

Hi hamidxa

This Code has been added to your Workbook

Option Explicit

Sub Copy_Sheets()
  Dim wkBk As Workbook, wkBk1 As Workbook
  Dim ws As Worksheet
  Dim rCell As Range
  Dim myPath As String, myNewPath As String, myFile As String, mySheet As String

  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set wkBk = ThisWorkbook
  myPath = wkBk.Path & "\"

  'Create New Folder to Hold Separate Workbooks if it does not exist
  myNewPath = wkBk.Path & "\" & "Test" & "\"  'Change "Test" to whatever you like
  If Len(Dir(myNewPath, vbDirectory)) = 0 Then
    MkDir (myNewPath)
  End If

  'If Separate Workbooks exist delete them
  On Error Resume Next
  Kill myNewPath & "*.xlsx"
  On Error GoTo 0

  'Create Separate Workbooks
  For Each rCell In Sheets("Temp").Range("B2", Sheets("Temp").Range("B" & Rows.Count).End(xlUp))
    On Error Resume Next
    Set wkBk1 = Workbooks.Add()
    Application.DisplayAlerts = False
    wkBk1.SaveAs myNewPath & rCell & ".xlsx"
    wkBk1.Close True
    Application.DisplayAlerts = True
    On Error GoTo 0
  Next rCell

  For Each ws In wkBk.Sheets
    If IsNumeric(Left(ws.Name, 2)) Then
      myFile = Left(ws.Name, 2) & ".xlsx"
      mySheet = ws.Name
      If CheckFileIsOpen(myFile) = False Then
        Workbooks.Open myNewPath & myFile
      End If

      Set wkBk1 = Workbooks(myFile)
      With wkBk1
        If Not Evaluate("ISREF('" & mySheet & ")'!A1)") Then
          Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheet
          ws.Cells.Copy
          ActiveSheet.Range("A1").PasteSpecial (xlPasteAll)
          Application.CutCopyMode = False
        End If
      End With
      Application.DisplayAlerts = False
      On Error Resume Next
      wkBk1.Sheets("Sheet1").Delete
      Application.DisplayAlerts = False
      On Error GoTo 0
      wkBk1.Close True
    End If
  Next ws
  Application.DisplayAlerts = False
  wkBk.Sheets("Temp").Delete
  Application.DisplayAlerts = True

  Application.EnableEvents = True
End Sub


Function CheckFileIsOpen(chkSumfile As String) As Boolean
  On Error Resume Next
  CheckFileIsOpen = (Workbooks(chkSumfile).Name = chkSumfile)
  On Error GoTo 0
End Function

You'll need to modify this line as desired

'Create New Folder to Hold Separate Workbooks if it does not exist
  myNewPath = wkBk.Path & "\" & "Test" & "\"  'Change "Test" to whatever you like
  If Len(Dir(myNewPath, vbDirectory)) = 0 Then
    MkDir (myNewPath)
  End If

The Code is called from this Procedure

Sub Macro2fromEF()
  Dim rCell As Range, rCell1 As Range, ws As Worksheet
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Sheets("Master")
    Sheets.Add().Name = "Temp"
    .Range("B1", .Range("B" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True
    .Range("G1", .Range("G" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("C1"), Unique:=True
    For Each rCell In Sheets("Temp").Range("B2", Sheets("Temp").Range("B" & Rows.Count).End(xlUp))
      For Each rCell1 In Sheets("Temp").Range("C2", Sheets("Temp").Range("C" & Rows.Count).End(xlUp))
        .Range("B1").AutoFilter Field:=2, Criteria1:=rCell
        .Range("G1").AutoFilter Field:=7, Criteria1:=rCell1
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = rCell & rCell1
        .AutoFilter.Range.Copy ws.Range("A2")
        .AutoFilterMode = False
      Next rCell1
    Next rCell
    '    Sheets("Temp").Delete
  End With
  Application.DisplayAlerts = True
  Call Copy_Sheets    'Called from here
  Application.ScreenUpdating = True
End Sub

Let me know of issues.

Hi hamidxa

I don't have the issue you describe but it's probably something in my settings.

Start from a clean Worksheet...only Master Worksheet.

Try this...if it does not work as expected there is a brute force solution...add the line of Code as indicated

For Each rCell In Sheets("Temp").Range("B2", Sheets("Temp").Range("B" & Rows.Count).End(xlUp))
    On Error Resume Next
    
    Application.SheetsInNewWorkbook = 1 'Add this line of Code
    Set wkBk1 = Workbooks.Add()
    Application.DisplayAlerts = False
    wkBk1.SaveAs myNewPath & rCell & ".xlsx"
    wkBk1.Close True
    Application.DisplayAlerts = True
    On Error GoTo 0
  Next rCell

Let me know of issues.