Splitting a workbook into multiple files AND adding a specific worksheet to each

[benparmer]

I am currently using the following procedure to take a spreadsheet with multiple worksheets to create and save each worksheet into separate files based on the worksheet names.

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

This works as expect but now I also need to add one unique worksheet to each workbook that is created through the process above, we'll call it "procedures", so that each saved worksheet has a second worksheet called procedures. I am stumped how to alter this process to add in that worksheet to each file. Alternatively, I am ok with a process to take this worksheet and add it to ALL files in a given folder. I have tried the process below with no luck as I get a vba/macro enabled save error on EACH file that opens to select yes or no, this is not something I wish to do as there are 100+ files, it needs to be automated. THANKS

Copy Worksheet from master file to multiple files in a folder with VBA

Hi, hoping someone can help me with this. I have a workbook called Rules which contains one worksheet also called Rules. I would like to take a mirror of this worksheet in its entirety and move a copy to all the excel files in a destination folder that I specify. I am using a third file as a...

www.mrexcel.com

 

[igold]

Hi benparmer- welcome to the MrExcel Forum:

Does this do what you want for the newly created workbooks...

Sub Splitbook()
'Updateby20140612
    Dim xPath As String, xWs As Worksheet
    xPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each xWs In ThisWorkbook.Sheets
        xWs.Copy
        With ActiveWorkbook
            .Worksheets.Add after:=Worksheets(1)
            ActiveSheet.Name = "procedures"
            ActiveSheet.Previous.Protect
        End With
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Please test on a backup copy of your work.

 

[benparmer]

Thank for your reply and YES, that did work...but I did get an error "Run-time error '1004' Application-defined or object-defined error". Not a deal breaker since it seems it worked as expected.

 

[igold]

You're welcome, I was happy to help. Thanks for the feedback.

When I tested I did not get any errors. Perhaps you tested it twice without deleting the first test. This kind of error can occur if you are trying rename an object with a name that already exists.

 

[benparmer]

Hate to complicate things, but is there a way to when you create each individual file that the unique worksheets that started as multiple tabs on the source file all be called one name like "data". I have a process to change a single and only worksheet in a file but now that the file has this procedures worksheet it complicates matters. Almost like somewhere after xWs.Copy, then do a rename in the new file, then copy over the procedures worksheet.

 

[igold]

Not sure I am following. Do you want to re-name the original sheet that created the workbook to the name "data" so that your new workbook will have two worksheets with one sheet named "data" and the second sheet named "procedures".

 

[benparmer]

Not sure I am following. Do you want to re-name the original sheet that created the workbook to the name "data" so that your new workbook will have two worksheets with one sheet named "data" and the second sheet named "procedures".

Yes, that is exactly it!

 

[benparmer]

Actually I figured it out how to rename after the copy. You've been super helpful, thanks again.

 

[igold]

This?

Sub Splitbook()
'Updateby20140612
    Dim xPath As String, xWs As Worksheet
    xPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each xWs In ThisWorkbook.Sheets
        xWs.Copy
        With ActiveWorkbook
            ActiveSheet.Name = "data"
            .Worksheets.Add after:=Worksheets(1)
            ActiveSheet.Name = "procedures"
            ActiveSheet.Previous.Protect
        End With
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[igold]

Happy to help. If it was not me it would of have been someone else. This is a very helpful (and friendly) forum.