MS Excel - Split Workbook into separate files per sheet

Category: Excel
Hits: 4262
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.
  1. Move the Excel file to an empty folder of its own

  2. With Excel open (ensure editing is enabled) hold down ALT and press F11 (Alt+F11)

  3. Go to Insert > Module and paste the below code
    copyraw 
    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
    1.  Sub SplitData() 
    2.      Dim WorkRng As Range 
    3.      Dim xRow As Range 
    4.      Dim SplitRow As Integer 
    5.      Dim xWs As Worksheet 
    6.      On Error Resume Next 
    7.      xTitleId = "JoelsTooCoolForExcel" 
    8.      Set WorkRng = Application.Selection 
    9.      Set WorkRng = Application.InputBox("Specify Data Range", xTitleId, WorkRng.Address, Type:=8) 
    10.      SplitRow = Application.InputBox("Specify Num Rows per Sheet", xTitleId, 5, Type:=1) 
    11.      Set xWs = WorkRng.Parent 
    12.      Set xRow = WorkRng.Rows(1) 
    13.      Application.ScreenUpdating = False 
    14.      For i = 1 To WorkRng.Rows.Count Step SplitRow 
    15.          resizeCount = SplitRow 
    16.          If (WorkRng.Rows.Count - xRow.Row + 1) < SplitRow Then resizeCount = WorkRng.Rows.Count - xRow.Row + 1 
    17.          xRow.Resize(resizeCount).Copy 
    18.          Application.Worksheets.Add after:=Application.Worksheets(Application.Worksheets.Count) 
    19.          Application.ActiveSheet.Range("A1").PasteSpecial 
    20.          Set xRow = xRow.Offset(SplitRow) 
    21.      Next 
    22.      Application.CutCopyMode = False 
    23.      Application.ScreenUpdating = True 
    24.  End Sub 


  4. 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.

  5. Using the above module, overwrite the code you previously pasted with the below (note the file format for Excel 97-2003):
    copyraw 
    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 


  6. Press F5 to run the code.

  7. 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:
  1. Splits one spreadsheet to several sheets within the same workbook.
  2. Inserts a blank row at the top of each of the created sheets.
  3. Copies the header from the first sheet into the top row of each created sheet.
  4. Splits each sheet to a separate XLS file.
copyraw 
' 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
  1.  ' Purpose: In the Excel File, split data ranges into individual sheets 
  2.  ' With Excel open (ensure editing is enabled)  press ALT+ F11 
  3.  ' Go to Insert > Module and paste below code 
  4.  ' Ensure your cursor is blinking in the "RunAll" subroutine (displays RunAll in the top right) 
  5.  ' Press F5 to run the code. 
  6.  ' You will be prompted for the total range (eg. $A1:$W36000) 
  7.  ' And then prompted for the number of rows per sheet (eg. 3000) 
  8.   
  9.  ' Run everything 
  10.  Sub RunAll() 
  11.      Call SplitData 
  12.      Call InsertRow 
  13.      Call CopyToAllSheets 
  14.      Call Splitbook 
  15.  End Sub 
  16.   
  17.  ' Split data to sheets 
  18.  Sub SplitData() 
  19.      Dim WorkRng As Range 
  20.      Dim xRow As Range 
  21.      Dim SplitRow As Integer 
  22.      Dim xWs As Worksheet 
  23.      On Error Resume Next 
  24.      xTitleId = "Joes Do Excel Stuff Script" 
  25.      Set WorkRng = Application.Selection 
  26.      Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8) 
  27.      SplitRow = Application.InputBox("Rows Per Sheet", xTitleId, 5, Type:=1) 
  28.      Set xWs = WorkRng.Parent 
  29.      Set xRow = WorkRng.Rows(1) 
  30.      Application.ScreenUpdating = False 
  31.      For i = 1 To WorkRng.Rows.Count Step SplitRow 
  32.          resizeCount = SplitRow 
  33.          If (WorkRng.Rows.Count - xRow.Row + 1) < SplitRow Then resizeCount = WorkRng.Rows.Count - xRow.Row + 1 
  34.          xRow.Resize(resizeCount).Copy 
  35.          Application.Worksheets.Add after:=Application.Worksheets(Application.Worksheets.Count) 
  36.          Application.ActiveSheet.Range("A1").PasteSpecial 
  37.          Set xRow = xRow.Offset(SplitRow) 
  38.      Next 
  39.      Application.CutCopyMode = False 
  40.      Application.ScreenUpdating = True 
  41.  End Sub 
  42.   
  43.  ' Add a blank row to the top each sheet 
  44.  Sub InsertRow() 
  45.      Rows(1).Insert Shift:=xlDown, _ 
  46.        CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow 
  47.  End Sub 
  48.   
  49.  ' Now copy the header row 
  50.  Sub CopyToAllSheets() 
  51.      Dim ws As Worksheet 
  52.      Set ws = ThisWorkbook.Sheets("Sheet1") 
  53.      Sheets.FillAcrossSheets ws.Range("1:1") 
  54.  End Sub 
  55.   
  56.  ' Now split to files 
  57.  Sub Splitbook() 
  58.      Dim xPath As String 
  59.      xPath = Application.ActiveWorkbook.Path 
  60.      Application.ScreenUpdating = False 
  61.      Application.DisplayAlerts = False 
  62.      For Each xWs In ThisWorkbook.Sheets 
  63.          xWs.Copy 
  64.          Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls", FileFormat:=-4143 
  65.          Application.ActiveWorkbook.Close False 
  66.      Next 
  67.      Application.DisplayAlerts = True 
  68.      Application.ScreenUpdating = True 
  69.  End Sub 

Source(s):
Category: Excel :: Article: 666

Latest Articles

Please publish modules in offcanvas position.