How to split spreadsheet into multiple spreadsheets with set number of rows?

Question

I have an Excel (2007) spreadsheet with 433 rows (plus the header row at the top). I need to split this up into 43 individual spreadsheet files with 10 rows each and one with the remaining 3 rows.

It would be preferable to have the header row at the top of each spreadsheet as well. How can I accomplish this?

Answer 1

Your macro is just splitting all the rows in the selected range, including the header row in the first row (so it will appear just one time, in the first file). I modified the macro for what you're asking; it's easy, review the comments I wrote to see what it does.

Sub Test()   Dim wb As Workbook   Dim ThisSheet As Worksheet   Dim NumOfColumns As Integer   Dim RangeToCopy As Range   Dim RangeOfHeader As Range        'data (range) of header row   Dim WorkbookCounter As Integer   Dim RowsInFile                    'how many rows (incl. header) in new files?    Application.ScreenUpdating = False    'Initialize data   Set ThisSheet = ThisWorkbook.ActiveSheet   NumOfColumns = ThisSheet.UsedRange.Columns.Count   WorkbookCounter = 1   RowsInFile = 10                   'as your example, just 10 rows per file    'Copy the data of the first row (header)   Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))    For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1     Set wb = Workbooks.Add      'Paste the header row in new file     RangeOfHeader.Copy wb.Sheets(1).Range("A1")      'Paste the chunk of rows for this file     Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))     RangeToCopy.Copy wb.Sheets(1).Range("A2")      'Save the new workbook, and close it     wb.SaveAs ThisWorkbook.Path & "\test" & WorkbookCounter     wb.Close      'Increment file counter     WorkbookCounter = WorkbookCounter + 1   Next p    Application.ScreenUpdating = True   Set wb = Nothing End Sub 

Hope this helps.

Answer 2

I updated the code by @Fer Garcia to Mac users ;), the change only in file saving method

Sub Test()   Dim wb As Workbook   Dim ThisSheet As Worksheet   Dim NumOfColumns As Integer   Dim RangeToCopy As Range   Dim RangeOfHeader As Range        'data (range) of header row   Dim WorkbookCounter As Integer   Dim RowsInFile                    'how many rows (incl. header) in new files?    Application.ScreenUpdating = False    'Initialize data   Set ThisSheet = ThisWorkbook.ActiveSheet   NumOfColumns = ThisSheet.UsedRange.Columns.Count   WorkbookCounter = 1   RowsInFile = 150                   'as your example, just 10 rows per file    'Copy the data of the first row (header)   Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))    For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1     Set wb = Workbooks.Add      'Paste the header row in new file     RangeOfHeader.Copy wb.Sheets(1).Range("A1")      'Paste the chunk of rows for this file     Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))     RangeToCopy.Copy wb.Sheets(1).Range("A2")      'Save the new workbook, and close it      wb.SaveAs "Test" & WorkbookCounter & ".xls", FileFormat:=57     wb.Close      'Increment file counter     WorkbookCounter = WorkbookCounter + 1   Next p    Application.ScreenUpdating = True   Set wb = Nothing End Sub