Split Worksheet into separate workbooks

[BBedford]

Hello- this is my first post and first time using VBA. So I apologize if I am using terms incorrectly. I am trying to split a workbook with 60+ tabs into separate workbooks. I am getting an error "Copy method of Worksheet class failed" . Can someone advise what I am doing incorrectly?

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 & ".xls"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Also, if it is possible I would like each workbook to save as name in a reference cell in that worksheet, not the tab name. Any suggestions?

thank you in advance!

[mancubus]

welcome to vbax.

please use code tags when pasting your macros. # button in qucik reply will do it for you.

assuming A1 cells in all worksheets contain the workbook names, try:

Sub Splitbook()

    Dim ws As Worksheet
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    For Each ws In ThisWorkbook.Worksheets
        ws.Copy
        With ActiveWorkbook
            .SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Range("A1") & ".xls", FileFormat:=56 '(56 = Excel8 excel file = .xls)
            .Close False
        End With
    Next
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

[BBedford]

Thank you for your reply. I am now getting an error "Run-time error '1004': Method 'SaveAs' of object '_workbook' failed."

[Paul_Hossler]

I've found that it's easier when dealing with more that one open WB, to create WB objects. It just seems to help me keep them straight

I'm assuming that you want each of the WB's created to be named as the worksheet that was copied

Option Explicit
Sub SplitSheets()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws As Worksheet
    Dim sPath1 As String, sPath2 As String
    
    
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path
    
    Application.ScreenUpdating = False
    
    For Each ws In wb1.Worksheets
        If ws.Visible Then
            ws.Copy
            Set wb2 = ActiveWorkbook
            sPath2 = sPath1 & Application.PathSeparator & ws.Name
            
            On Error Resume Next
            Kill sPath2 & ".xlsx"
            On Error GoTo 0
            
            Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
            Call wb2.Close(False)
        End If
    Next
    
    wb1.Activate
    Application.ScreenUpdating = False
End Sub

[BBedford]

Hi Paul. The Macro worked-Thank you. I am trying to save the workbooks as a name in a reference cell "F7" in each of the workbooks. I have tried updating the code but received another error. Where should I put this reference in the code?

[Paul_Hossler]

Hi Paul. The Macro worked-Thank you. I am trying to save the workbooks as a name in a reference cell "F7" in each of the workbooks. I have tried updating the code but received another error. Where should I put this reference in the code?

If you mean that you want the created workbooks to be named based on the F7 on each worksheet, change

sPath2 = sPath1 & Application.PathSeparator & ws.Name

to

sPath2 = sPath1 & Application.PathSeparator & ws.Range("F7").Text

But to handle the case where these is a error (#DIV/0! or some other problem) in F7, I added a little error handling

Option Explicit
Sub SplitSheets()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws As Worksheet
    Dim sPath1 As String, sPath2 As String
    
    
    Set wb1 = ThisWorkbook
    sPath1 = wb1.Path
    
    Application.ScreenUpdating = False
    
    For Each ws In wb1.Worksheets
        If ws.Visible Then
            ws.Copy
            Set wb2 = ActiveWorkbook
            sPath2 = sPath1 & Application.PathSeparator & ws.Range("F7").Text
            
            On Error Resume Next
            Kill sPath2 & ".xlsx"
            On Error GoTo 0
            
            On Error GoTo CanNotSaveIt
            Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
            Call wb2.Close(False)
                    
        

        End If
    Next
    
    wb1.Activate
    Application.ScreenUpdating = False

    Exit Sub
    
CanNotSaveIt:
    Call MsgBox("Can not save" & vbCrLf & vbCrLf & sPath2, vbCritical + vbOKOnly, "Split Workbook")
    Resume Next
End Sub

[BBedford]

Thank you all so much!!!! This worked like a charm and has saved me a lot of time!

[dgxcook]

Hey Paul!

The above is exactly what I am needing.

However, I am trying to have this in my personal.xlsb file so I may use it as needed in other workbooks. When I run this from another workbook it saves copies of the worksheets in personal.xlsb.

Any advice?

[Paul_Hossler]

Really only need one line changed (<<<<<<) but I added an error check and better variable names

Option Explicit

Sub SplitSheets()
    Dim wbSource As Workbook, wbDest As Workbook
    Dim ws As Worksheet
    Dim sPath1 As String, sPath2 As String
    
    If ActiveWorkbook Is Nothing Then
        Call MsgBox("You need an Active Workbook", vbCritical + vbOKOnly, "Split Workbook")
        Exit Sub
    End If
    
    Set wbSource = ActiveWorkbook    '<<<<<<<<<<<<<<<<<<
    sPath1 = wbSource.Path
    
    Application.ScreenUpdating = False
    
    For Each ws In wbSource.Worksheets
        If ws.Visible Then
            ws.Copy
            Set wbDest = ActiveWorkbook
            sPath2 = sPath1 & Application.PathSeparator & ws.Range("F7").Text
            
            On Error Resume Next
            Kill sPath2 & ".xlsx"
            On Error GoTo 0
            
            On Error GoTo CanNotSaveIt
            Call wbDest.SaveAs(sPath2, xlOpenXMLWorkbook)
            Call wbDest.Close(False)
        End If
    Next
    
    wbSource.Activate
    Application.ScreenUpdating = False
    Exit Sub
    
CanNotSaveIt:
    Call MsgBox("Can not save" & vbCrLf & vbCrLf & sPath2, vbCritical + vbOKOnly, "Split Workbook")
    Resume Next
End Sub

[dgxcook]

Hey Paul!

Thanks for the response. I'm now getting an error "can not save" when I try to run this.

[Paul_Hossler]

what version of Excel?

[dgxcook]

Office 365.

[Paul_Hossler]

Are you using .xls or .xlsx files?

Otherwise, I can't guess why if doesn't save


Comment out the On Error and see what the Excel error message is

[1702213]

Are you using .xls or .xlsx files?

Otherwise, I can't guess why if doesn't save


Comment out the On Error and see what the Excel error message is

Hi, sorry to open an old thread. I also had an issue with .xlsx files, so I switched to .xls... and all it saves is a "Lodging.txt" file in the path location. Any suggestions?

[CharlieP]

I am using the same formula to create individual workbooks by tab name, but my files use Month, YTD and Full Year tabs, so each person will have a name, name(2) and name(3) tab prior to VBA utilization (of course cannot have redundant tab names in excel). I'm wondering is there an option to combine these tabs into one workbook so ideally each person will have an individual workbook containing Month, YTD and Full Year tabs, i've heard you can pull by the first X characters of a tab name, but even more ideally would be if it could combine like tab names while excluding numbers and special characters. Any insight would be greatly appreciated.

welcome to vbax.

please use code tags when pasting your macros. # button in qucik reply will do it for you.

assuming A1 cells in all worksheets contain the workbook names, try:

Sub Splitbook()

    Dim ws As Worksheet
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    For Each ws In ThisWorkbook.Worksheets
        ws.Copy
        With ActiveWorkbook
            .SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Range("A1") & ".xls", FileFormat:=56 '(56 = Excel8 excel file = .xls)
            .Close False
        End With
    Next
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub