Macro to Split Workbook into separate Workbooks

Hi

I have a large workbook with many worksheets which are all grouped into pairs - i.e. Sheet1 & Sheet2 go together, Sheet3 & Sheet4 go together; Sheet5 & Sheet6 go together, etc. etc.

I need a macro to divide this workbook into separate workbooks where each group of worksheets has a separate file of its own and I want to name the new workbooks after the second sheet in each group:

i.e. A new workbook for Sheet1 & Sheet2 called Sheet2.xls; a new workbook for Sheet3 & Sheet4 called Sheet4.xls; a new workbook for Sheet5 & Sheet6 called Sheet6.xls; etc. etc. etc.

Appreciate any help I can get on this.
Ta
John

The two sheets are in order and together?
There are an even number of sheets?
The original workbook is to be preserved?

Give this a try:

Sub NoahsWorkbooks()
'Divide workbook into sheet pairs  (JBeaucaire - 7/7/2009)
Dim Cnt As Long, i As Long, strPath As String
strPath = "C:\Documents and Settings\Jerry\Desktop\Test\"
Cnt = Sheets.Count

    For i = 1 To Cnt Step 2
        Sheets(Array("Sheet" & i, "Sheet" & i + 1)).Copy
        
        ActiveWorkbook.SaveAs Filename:=strPath & "Sheet" & i + 1 & ".xls", _
            FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
        
        ActiveWorkbook.Close
    Next i

End Sub

Be sure to set your strPath properly, including that closing "\".

Can you attach a dummy workbook.

The suggestd code doesn't wok because the array needs to contain the sheet names, yours ar not named Sheet1, etc. This amendment will get the sheet names & build the array

Option Explicit

Sub NoahsWorkbooks()
    'Divide workbook into sheet pairs  
    Dim Cnt    As Long
    Dim i      As Long
    Dim strPath As String
    Dim Sht1   As String
    Dim Sht2   As String

    strPath = "C:\TestMacro\"    '<-change the path to suit
    Cnt = Sheets.Count
    For i = 1 To Cnt Step 2
        Sht1 = Sheets(i).Name
        Sht2 = Sheets(i + 1).Name
        Sheets(Array(Sht1, Sht2)).Copy

        ActiveWorkbook.SaveAs Filename:=strPath & Sht2 & ".xls", _
                              FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
                              ReadOnlyRecommended:=False, CreateBackup:=False

        ActiveWorkbook.Close
    Next i
End Sub

        Sht1 = Sheets(i).Name
        Sht2 = Sheets(i + 1).Name
        Sheets(Array(Sht1, Sht2)).Copy

That's great, Roy!

Thanks both

jmurray please mark this thread solved

chenelas
Your post does not comply with Rule 2 of our Forum RULES. Don't post a question in the thread of another member -- start your own thread. If you feel it's particularly relevant, provide a link to the other thread.