MS Excel - Split Workbook into separate files per sheet

: Joel Lipman; Excel; 11 February 2019; Hits: 3405

What?
This article serves to explain how to split a spreadsheet consisting of multiple sheets into separate files per sheet.

Why?
The Excel file in question was about 36000 rows and had a file size of about 11Mb. In order for an import process to work, the import would only accept XLS files no greater than 1Mb. So our script has to split a single spreadsheet into multiple worksheets of 3000 rows each, and then output each sheet to a separate file that is formatted as XLS (Not *.xlsx).

How?
In summary, we are going to move the Excel file to a folder of its own. We're going to run two VBScripts in two stages, firstly to split the specified rows into sheets, then each sheet into a file each. And we want all the files generated to be created in the same folder.

Move the Excel file to an empty folder of its own
With Excel open (ensure editing is enabled) hold down ALT and press F11 (Alt+F11)

Go to Insert > Module and paste the below code

copy raw

Sub SplitData()
    Dim WorkRng As Range
    Dim xRow As Range
    Dim SplitRow As Integer
    Dim xWs As Worksheet
    On Error Resume Next
    xTitleId = "JoelsTooCoolForExcel"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Specify Data Range", xTitleId, WorkRng.Address, Type:=8)
    SplitRow = Application.InputBox("Specify Num Rows per Sheet", xTitleId, 5, Type:=1)
    Set xWs = WorkRng.Parent
    Set xRow = WorkRng.Rows(1)
    Application.ScreenUpdating = False
    For i = 1 To WorkRng.Rows.Count Step SplitRow
        resizeCount = SplitRow
        If (WorkRng.Rows.Count - xRow.Row + 1) < SplitRow Then resizeCount = WorkRng.Rows.Count - xRow.Row + 1
        xRow.Resize(resizeCount).Copy
        Application.Worksheets.Add after:=Application.Worksheets(Application.Worksheets.Count)
        Application.ActiveSheet.Range("A1").PasteSpecial
        Set xRow = xRow.Offset(SplitRow)
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Sub SplitData()
Dim WorkRng As Range
Dim xRow As Range
Dim SplitRow As Integer
Dim xWs As Worksheet
On Error Resume Next
xTitleId = "JoelsTooCoolForExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Specify Data Range", xTitleId, WorkRng.Address, Type:=8)
SplitRow = Application.InputBox("Specify Num Rows per Sheet", xTitleId, 5, Type:=1)
Set xWs = WorkRng.Parent
Set xRow = WorkRng.Rows(1)
Application.ScreenUpdating = False
For i = 1 To WorkRng.Rows.Count Step SplitRow
resizeCount = SplitRow
If (WorkRng.Rows.Count - xRow.Row + 1) < SplitRow Then resizeCount = WorkRng.Rows.Count - xRow.Row + 1
xRow.Resize(resizeCount).Copy
Application.Worksheets.Add after:=Application.Worksheets(Application.Worksheets.Count)
Application.ActiveSheet.Range("A1").PasteSpecial
Set xRow = xRow.Offset(SplitRow)
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Press F5 to run the code. This will prompt you twice:
1. It is prompting you for the range of all the data to apply this to (eg. $A1:$W36000).
2. You are then prompted for the number of rows per sheet (eg. 3000).
In my example, this will produce an extra 12 worksheets in this file.
Using the above module, overwrite the code you previously pasted with the below (note the file format for Excel 97-2003):
copyrawstyler
```
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", FileFormat:=-4143
        Application.ActiveWorkbook.Close False
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
```
1. Sub Splitbook()
2. Dim xPath As String
3. xPath = Application.ActiveWorkbook.Path
4. Application.ScreenUpdating = False
5. Application.DisplayAlerts = False
6. For Each xWs In ThisWorkbook.Sheets
7. xWs.Copy
8. Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls", FileFormat:=-4143
9. Application.ActiveWorkbook.Close False
10. Next
11. Application.DisplayAlerts = True
12. Application.ScreenUpdating = True
13. End Sub
Press F5 to run the code.
A separate file will be created for each sheet in the same folder.

A combined all-in-one solution
The following script is made of 4/5 subroutines. Follow the instructions above on how to execute a vbscript and then paste the below into the developer window. Ensure that your mouse cursor has focus in the first subroutine "RunAll".

Here's a quick summary of what the below script does:

Splits one spreadsheet to several sheets within the same workbook.
Inserts a blank row at the top of each of the created sheets.
Copies the header from the first sheet into the top row of each created sheet.
Splits each sheet to a separate XLS file.

copy raw

' Purpose: In the Excel File, split data ranges into individual sheets
' With Excel open (ensure editing is enabled)  press ALT+ F11
' Go to Insert > Module and paste below code
' Ensure your cursor is blinking in the "RunAll" subroutine (displays RunAll in the top right)
' Press F5 to run the code.
' You will be prompted for the total range (eg. $A1:$W36000)
' And then prompted for the number of rows per sheet (eg. 3000)

' Run everything
Sub RunAll()
    Call SplitData
    Call InsertRow
    Call CopyToAllSheets
    Call Splitbook
End Sub

' Split data to sheets
Sub SplitData()
    Dim WorkRng As Range
    Dim xRow As Range
    Dim SplitRow As Integer
    Dim xWs As Worksheet
    On Error Resume Next
    xTitleId = "Joes Do Excel Stuff Script"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    SplitRow = Application.InputBox("Rows Per Sheet", xTitleId, 5, Type:=1)
    Set xWs = WorkRng.Parent
    Set xRow = WorkRng.Rows(1)
    Application.ScreenUpdating = False
    For i = 1 To WorkRng.Rows.Count Step SplitRow
        resizeCount = SplitRow
        If (WorkRng.Rows.Count - xRow.Row + 1) < SplitRow Then resizeCount = WorkRng.Rows.Count - xRow.Row + 1
        xRow.Resize(resizeCount).Copy
        Application.Worksheets.Add after:=Application.Worksheets(Application.Worksheets.Count)
        Application.ActiveSheet.Range("A1").PasteSpecial
        Set xRow = xRow.Offset(SplitRow)
    Next
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

' Add a blank row to the top each sheet
Sub InsertRow()
    Rows(1).Insert Shift:=xlDown, _
      CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
End Sub

' Now copy the header row
Sub CopyToAllSheets()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Sheets.FillAcrossSheets ws.Range("1:1")
End Sub

' Now split to files
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", FileFormat:=-4143
        Application.ActiveWorkbook.Close False
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

' Purpose: In the Excel File, split data ranges into individual sheets
' With Excel open (ensure editing is enabled) press ALT+ F11
' Go to Insert > Module and paste below code
' Ensure your cursor is blinking in the "RunAll" subroutine (displays RunAll in the top right)
' Press F5 to run the code.
' You will be prompted for the total range (eg. $A1:$W36000)
' And then prompted for the number of rows per sheet (eg. 3000)
' Run everything
Sub RunAll()
Call SplitData
Call InsertRow
Call CopyToAllSheets
Call Splitbook
End Sub
' Split data to sheets
Sub SplitData()
Dim WorkRng As Range
Dim xRow As Range
Dim SplitRow As Integer
Dim xWs As Worksheet
On Error Resume Next
xTitleId = "Joes Do Excel Stuff Script"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
SplitRow = Application.InputBox("Rows Per Sheet", xTitleId, 5, Type:=1)
Set xWs = WorkRng.Parent
Set xRow = WorkRng.Rows(1)
Application.ScreenUpdating = False
For i = 1 To WorkRng.Rows.Count Step SplitRow
resizeCount = SplitRow
If (WorkRng.Rows.Count - xRow.Row + 1) < SplitRow Then resizeCount = WorkRng.Rows.Count - xRow.Row + 1
xRow.Resize(resizeCount).Copy
Application.Worksheets.Add after:=Application.Worksheets(Application.Worksheets.Count)
Application.ActiveSheet.Range("A1").PasteSpecial
Set xRow = xRow.Offset(SplitRow)
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
' Add a blank row to the top each sheet
Sub InsertRow()
Rows(1).Insert Shift:=xlDown, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
End Sub
' Now copy the header row
Sub CopyToAllSheets()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Sheets.FillAcrossSheets ws.Range("1:1")
End Sub
' Now split to files
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", FileFormat:=-4143
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub