I’m attempting to write a macro to take an excel file of several thousand rows and split the inital sheet’s rows up into sheets of 250 rows per-sheet, not including the original header row, which should also be copied to each sheet. There are 13 columns total, and some of the fields are empty.
I can sort the document myself – that’s not an issue – I just don’t have the macro skill to figure this one out.
I’ve tried searching, and found a few examples, but none quite fit..such as this one..
create macro that will convert excel rows from single sheet to new sheets ..or this one.. Save data input from one sheet onto successive rows in another sheet
This should provide the solution you are looking for as well. You actually added your answer as I was typing it, but maybe someone will find it useful.
This method only requires that you enter the number of rows to copy to each page, and assumes you are on the “main” page once you execute it.
Sub AddSheets() Application.EnableEvents = False Dim wsMasterSheet As Excel.Worksheet Dim wb As Excel.Workbook Dim sheetCount As Integer Dim rowCount As Integer Dim rowsPerSheet As Integer Set wsMasterSheet = ActiveSheet Set wb = ActiveWorkbook rowsPerSheet = 5 rowCount = Application.CountA(Sheets(1).Range("A:A")) sheetCount = Round(rowCount / rowsPerSheet, 0) Dim i As Integer For i = 1 To sheetCount - 1 Step 1 With wb 'Add new sheet .Sheets.Add after:=.Sheets(.Sheets.Count) wsMasterSheet.Range("A1:M1").EntireRow.Copy Destination:=Sheets(.Sheets.Count).Range("A1").End(xlUp) wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Cut Destination:=Sheets(.Sheets.Count).Range("A" & Rows.Count).End(xlUp).Offset(1) wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Delete ActiveSheet.Name = "Rows " + CStr(((.Sheets.Count - 1) * rowsPerSheet + 1)) & " - " & CStr((.Sheets.Count * rowsPerSheet)) End With Next wsMasterSheet.Name = "Rows 1 - " & rowsPerSheet Application.EnableEvents = True End Sub
@pnuts’s suggested solution by Jerry Beaucaire worked perfectly.
Option Explicit Sub SplitDataNrows() 'Jerry Beaucaire, 2/28/2012 'Split a data sheet by a variable number or rows per sheet, optional titles Dim N As Long, rw As Long, LR As Long, Titles As Boolean If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, _ "Confirm") = vbNo Then Exit Sub N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1) If N = 0 Then Exit Sub If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _ "Titles?") = vbYes Then Titles = True Application.ScreenUpdating = False With ActiveSheet LR = .Range("A" & .Rows.Count).End(xlUp).Row For rw = 1 + ---Titles To LR Step N Sheets.Add If Titles Then .Rows(1).Copy Range("A1") .Range("A" & rw).Resize(N).EntireRow.Copy Range("A2") Else .Range("A" & rw).Resize(N).EntireRow.Copy Range("A1") End If Columns.AutoFit Next rw .Activate End With Application.ScreenUpdating = True End Sub
Option Explicit Sub SplitWorkbooksByNrows() 'Jerry Beaucaire, 2/28/2012 'Split all data sheets in a folder by a variable number or rows per sheet, optional titles 'assumes only one worksheet of data per workbook Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range srcPATH = "C:\Path\To\Source\Files\" 'remember the final \ in this string destPATH = "C:\Path\To\Save\NewFiles\" 'remember the final \ in this string 'determine how many rows per sheet to create N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1) If N = 0 Then Exit Sub 'exit if user clicks CANCEL 'Examples of usable ranges: A:A A:Z C:E F:F Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2) If Cols = "False" Then Exit Sub 'exit if user clicks CANCEL 'prompt to repeat row1 titles on each created sheet If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _ "Titles?") = vbYes Then Titles = True Application.ScreenUpdating = False 'speed up macro execution Application.DisplayAlerts = False 'turn off system alert messages, use default answers fNAME = Dir(srcPATH & "*.xlsx") 'get first filename from srcPATH Do While Len(fNAME) > 0 'exit loop when no more files found Set wbDATA = Workbooks.Open(srcPATH & fNAME) 'open found file With ActiveSheet LR = Intersect(.Range(Cols), .UsedRange).Rows.Count 'how many rows of data? If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt. For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows Cnt = Cnt + 1 'increment the sheet creation counter Sheets.Add 'create the new sheet If Titles Then titleRNG.Copy Range("A1") 'optionally add the titles 'copy N rows of data to new sheet Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles) ActiveSheet.Columns.AutoFit 'cleanup ActiveSheet.Move 'move created sheet to new workbook 'save with incremented filename in the destPATH ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal ActiveWorkbook.Close False 'close the created workbook Next rw 'repeat with next set of rows End With wbDATA.Close False 'close source data workbook fNAME = Dir 'get next filename from the srcPATH Loop 'repeat for each found file Application.ScreenUpdating = True 'return to normal speed MsgBox "A total of " & Cnt & " data files were created." 'report End Sub