Created
August 15, 2011 19:51
-
-
Save MikeWills/1147626 to your computer and use it in GitHub Desktop.
This Excel Macro will split a sheet of thousands of rows and break them into multiple sheets with 2000 rows each.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
// 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
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 !