Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
This Excel Macro will split a sheet of thousands of rows and break them into multiple sheets with 2000 rows each.
// This code was taken off the PCTECH mailing list from the following message thread:
// http://archive.midrange.com/pctech/201108/msg00084.html
// Written by Jim O. and slj
Sub split_up()
Dim rLastCell As Range
Dim rCells As Range
Dim strName As String
Dim lLoop As Long, lCopy As Long
Dim wbNew As Workbook
Dim wrkname As String
Dim posfound As Integer
Dim length1 As Integer
wrkname = ThisWorkbook.Name
length1 = Len(wrkname)
posfound = InStr(1, wrkname, ".xlsx")
wrkname = Mid(wrkname, 1, (length1 - (length1 - posfound + 1)))
With ThisWorkbook.Sheets(1)
Set rLastCell = .Cells.Find(What:="*", After:=[A1],
SearchDirection:=xlPrevious)
For lLoop = 1 To rLastCell.Row Step 2000
lCopy = lCopy + 1
Set wbNew = Workbooks.Add.Range(.Cells(lLoop, 1), .Cells(lLoop + 2000,.Columns.Count)).EntireRow.Copy_Destination:=wbNew.Sheets(1).Range("A1")
wbNew.Close SaveChanges:=True, Filename:=wrkname & lCopy & "Rows" & lLoop & "-" & lLoop + 2000
Next lLoop
End With
End Sub
@ZuluagaSD
Copy link

ZuluagaSD commented May 21, 2013

Hey, first of all, thanks for making this macro, it would help me a lot if I get it to work, I am currently getting an error on line 28, it says there is a problem with the syntax.
Again thanks for the help !

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment