Export groups of worksheets into separate workbooks based on an index sheet

[mathewwheeler]

I am trying to separate my file into multiple files based on an index sheet with two columns: the sheet name and the name I would like to save the new workbook as. Can anyone help create VBA code that will reference columnA (new workbook name) and export all sheets (based on their name in columnB) into that one file? Ideally the code would cycle through until it exports all worksheets.

 

[Yongle]

Make sure that your worksheet looks like mine (headers in row1, data starts in A2)
Amend Path & SheetName
Test on a COPY of your workbook

Excel 2016 (Windows) 32 bit

	A​	B​
1​	Workbook	SHEET
2​	wb2	Sheet2
3​	wb1	Sheet3
4​	wb2	Sheet4
5​	wb3	Sheet5
6​	wb3	Sheet6
7​	wb4	Sheet7
8​	wb1	Sheet8
9​	wb1	Sheet9

Sheet: Index

[COLOR=#006400]Sub SplitWorkbook()[/COLOR]
    Const path = "[COLOR=#ff0000]C:\folder\subfolder[/COLOR]"
    Dim WbMain As Workbook, Wb As Workbook, Ws As Worksheet, Cel As Range, Rng1 As Range, Rng2 As Range
    Dim Coll As New Collection, Itm As Variant
    Set WbMain = ThisWorkbook:      Set Ws = WbMain.Sheets("[COLOR=#ff0000]Index[/COLOR]")
    Set Rng1 = Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
    Set Rng2 = Ws.Range("A1", Ws.Range("A" & Rows.Count).End(xlUp))
    Optimize True
[COLOR=#a52a2a][I]'get unique list of workbooks[/I][/COLOR]
    For Each Cel In Rng1
        On Error Resume Next: Coll.Add CStr(Cel), CStr(Cel): On Error GoTo 0
    Next
[COLOR=#a52a2a][I]'filter list in sheet "Index", add workbooks & copy sheets[/I][/COLOR]
    Ws.AutoFilterMode = False
    For Each Itm In Coll
        Rng2.AutoFilter Field:=1, Criteria1:=Itm
        Set Wb = Workbooks.Add
        For Each Cel In Rng1.SpecialCells(xlCellTypeVisible)
            WbMain.Sheets(Cel.Offset(, 1).Value).Copy before:=Wb.Sheets(Wb.Worksheets.Count)
        Next Cel
        Wb.SaveAs path & Chr(92) & Itm & Format(Now, " YYMMDD HHMMSS")
        Wb.Close False
        Ws.AutoFilterMode = False
    Next Itm
Optimize False
[COLOR=#006400]End Sub[/COLOR]
[COLOR=#006400]Private Sub Optimize(TrueFalse As Boolean)[/COLOR]
    With Application
        .ScreenUpdating = Not TrueFalse
        .Calculation = xlCalculationManual
        If TrueFalse = True Then Else .Calculation = xlCalculationAutomatic
    End With
[COLOR=#006400]End Sub[/COLOR]

 

[mathewwheeler]

That is very helpful! Thank you.

Could you help me adjust the macro to export as PDF instead of separate excel files? Appreciate all of your help thus far.

 

[Yongle]

Is this what you want?
- create workbook as before
- select all sheets in created workbook except last sheet (default Sheet1 when workbook created)
- save selected sheets to PDF
- close workbook without saving

[COLOR=#006400]Sub SplitWorkbookToPDF[/COLOR]()
    Const path = "C:\folder\subfolder"
    Dim WbMain As Workbook, Wb As Workbook, Ws As Worksheet, Cel As Range, Rng1 As Range, Rng2 As Range[COLOR=#006400], w As Long[/COLOR]
    Dim Coll As New Collection, Itm As Variant
    Set WbMain = ThisWorkbook:      Set Ws = WbMain.Sheets("Index")
    Set Rng1 = Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
    Set Rng2 = Ws.Range("A1", Ws.Range("A" & Rows.Count).End(xlUp))
    Optimize True
'get unique list of workbooks
    For Each Cel In Rng1
        On Error Resume Next: Coll.Add CStr(Cel), CStr(Cel): On Error GoTo 0
    Next
'filter list in sheet "Index", add workbooks & copy sheets
    Ws.AutoFilterMode = False
    For Each Itm In Coll
        Rng2.AutoFilter Field:=1, Criteria1:=Itm
        Set Wb = Workbooks.Add
        For Each Cel In Rng1.SpecialCells(xlCellTypeVisible)
            WbMain.Sheets(Cel.Offset(, 1).Value).Copy before:=Wb.Sheets(Wb.Worksheets.Count)
        Next Cel
[COLOR=#006400]        For w = 1 To Wb.Sheets.Count - 1
            Wb.Sheets(w).Select False
        Next w[/COLOR]
       [COLOR=#006400] ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=path & Chr(92) & Itm & Format(Now, " YYMMDD HHMMSS")[/COLOR]
        Wb.Close False
        Ws.AutoFilterMode = False
    Next Itm
Optimize False
[COLOR=#006400]End Sub
[/COLOR]
[COLOR=#006400]Private Sub Optimize(TrueFalse As Boolean)[/COLOR]
    With Application
        .ScreenUpdating = Not TrueFalse
        .Calculation = xlCalculationManual
        If TrueFalse = True Then Else .Calculation = xlCalculationAutomatic
    End With
[COLOR=#006400]End Sub[/COLOR]

 

[mathewwheeler]

That is perfect - thank you both for your help!

 

[Yongle]

thanks for the feedback