Program Macro to create new workbooks only if more than 50 rows.

[rplohocky]

Hello,
I have to do a data base query that has over 500 rows of data. I need to break up this data into separate workbooks that has a maximum of 50 rows per workbook. Because the query has a different row count each time I need to create a macro that will look down column A and see that their are more than 50 rows and extract the next 50 rows into a new workbook and then look again after that 50 and extract another 50 and so on until the original workbook remains with the first 50 rows of data.

Example: The macro would look at A51:A101 and generate a new workbook and then go back and look at A102:A152 and generate another workbook and so on. This would continue until all rows are clear except for the first 50 rows.

 

[MattH1]

I didn't test the code, let me know if this runs as you would like. Also take note that cells 1-50 are in one sheet, 51-100 are in the next (not 51-101 and 102-152).

Sub Splicer()
Dim NumSheets as Integer
Dim RowCount As Long
Dim CopyCells1 As Integer
Dim CopyCells2 As Integer
RowCount = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

NumSheets = Round((RowCount/5),0) + 1

For I = 1 to NumSheets
Set NewBook = Workbooks.Add
CopyCells1 = 50* (I-1) + 1
CopyCells2 = 50 * (I)
Workbooks("MAINBOOKNAME").Worksheets("MAINWORKSHEETNAME").Cells(Cells(1,CopyCells1),Cells(1,CopyCells2)).EntireRow.Copy 'Edit this with current workbook name and worksheet name
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
NewBook.SaveAs FileName:= "WHATEVER YOU WANT" & .xlsx 'Edit this part to include the file you want to save it as.
Next I

End Sub

 

[MattH1]

Round will also round up, I've changed the code below to fix this error:

Sub Splicer()
Dim NumSheets as Integer
Dim RowCount As Long
Dim CopyCells1 As Integer
Dim CopyCells2 As Integer
RowCount = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

NumSheets = Int((RowCount/5),0) + 1

For I = 1 to NumSheets
Set NewBook = Workbooks.Add
CopyCells1 = 50* (I-1) + 1
CopyCells2 = 50 * (I)
Workbooks("MAINBOOKNAME").Worksheets("MAINWORKSHEETNAME").Cells(Cells(1,CopyCells1),Cells(1,CopyCells2)).EntireRow.Copy 'Edit this with current workbook name and worksheet name
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
NewBook.SaveAs FileName:= "WHATEVER YOU WANT" & .xlsx 'Edit this part to include the file you want to save it as.
Next I

End Sub

 

[rplohocky]

MattH1,
I inserted the code and modified the workbook name and sheet name but i'm getting an error in this line:

Workbooks("Book2").Worksheets("DataSheet").Cells(Cells(1, CopyCells1), Cells(1, CopyCells2)).EntireRow.Copy

The names are correct and i can't see anything wrong. However it is creating new workbooks but gets hung up at this line.

Your new code seems to have an issue on this line:

NumSheets = Int((RowCount/5),0) + 1

Not sure what's happening here either. Thanks for your help so far!!

 

[MattH1]

MattH1,
I inserted the code and modified the workbook name and sheet name but i'm getting an error in this line:

Workbooks("Book2").Worksheets("DataSheet").Cells(Cells(1, CopyCells1), Cells(1, CopyCells2)).EntireRow.Copy

The names are correct and i can't see anything wrong. However it is creating new workbooks but gets hung up at this line.

Your new code seems to have an issue on this line:

NumSheets = Int((RowCount/5),0) + 1

Not sure what's happening here either. Thanks for your help so far!!

Hey rplohocky,
Hope these edits help! Fixed NumSheets and fixed the save file. The problem was that the save file and the piece .xlsx should have been in quotes (my mistake, happens when you don't run the code yourself!!)

I hope this new code gives you no errors, it's just quotes around the .xlsx and a fixed NumSheets formula.

Sub Splicer()
Dim NumSheets as Integer
Dim RowCount As Long
Dim CopyCells1 As Integer
Dim CopyCells2 As Integer
RowCount = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

NumSheets = RowCount/50 + 1 'This is the edit. It'll give you how many sheets you're making

For I = 1 to NumSheets
Set NewBook = Workbooks.Add
CopyCells1 = 50* (I-1) + 1
CopyCells2 = 50 * (I)
Workbooks("MAINBOOKNAME").Worksheets("MAINWORKSHEETNAME").Cells(Cells(1,CopyCells1),Cells(1,CopyCells2)).EntireRow.Copy 'Edit this with current workbook name and worksheet name
NewBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteValues)
NewBook.SaveAs FileName:= "WHATEVER YOU WANT" & ."xlsx" 'Edit this part to include the file you want to save it as.
Next I

End Sub