Split Every N Rows From Worksheet Into New Worksheets

S

supermat

New Member
Joined
Dec 17, 2008
Messages
3
I have a large worksheet. Over 20,000 rows. I want to split every 900 rows into new worksheets. I need each worksheet to be 900 rows or less when done. Any macro would be helpful.
 
Last edited:

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
Try something like:

Code: 
Sub test()
Dim lastRow As Long, myRow As Long, myBook As Workbook
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For myRow = 2 To lastRow Step 900
    Set myBook = Workbooks.Add
    ThisWorkbook.Sheets("Sheet1").Rows(myRow & ":" & myRow + 899).EntireRow.Copy myBook.Sheets("Sheet1").Range("A1")
Next myRow
End Sub

Dom
 
Upvote 0
Sure:

Code: 
Sub test()
Dim lastRow As Long, myRow As Long, mySheet As Worksheet
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For myRow = 2 To lastRow Step 900
    Set mySheet = Worksheets.Add
    Sheets("Sheet1").Rows(myRow & ":" & myRow + 899).EntireRow.Copy mySheet.Range("A1")
Next myRow
End Sub

Dom
 
Upvote 0
I tried this and it worked...thanks for the help.
Sub SplitWorksheet()
Dim lngLastRow As Long
Dim lngNumberOfRows As Long
Dim lngI As Long
Dim strMainSheetName As String
Dim currSheet As Worksheet
Dim prevSheet As Worksheet
'Number of rows to split among worksheets
lngNumberOfRows = 900
'Current worksheet in workbook
Set prevSheet = ThisWorkbook.ActiveSheet
'First worksheet name
strMainSheetName = prevSheet.Name
'Number of rows in worksheet
lngLastRow = prevSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Worksheet counter for added worksheets
lngI = 1
While lngLastRow > lngNumberOfRows
Set currSheet = ThisWorkbook.Worksheets.Add
With currSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = strMainSheetName + "(" + CStr(lngI) + ")"
End With

With prevSheet.Rows(lngNumberOfRows + 1 & ":" & lngLastRow).EntireRow
.Cut currSheet.Range("A1")
End With

lngLastRow = currSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set prevSheet = currSheet
lngI = lngI + 1
Wend
End Sub
 
Upvote 0
Here is my version:
Code: 
Sub CopyTable()
 
    'Set dimensions
    Dim Table As Range, TableArray(), _
        CutValue As Integer, Cntr As Integer, _
        TempArray(), Width As Integer, _
        x As Integer, y As Integer, _
        Height As Long, Rep As Integer, _
        LoopReps As Long
 
    'Get data
    Set Table = Application.InputBox("Specify range to copy", _
        Default:=ActiveCell.CurrentRegion.Address, Type:=8)
    CutValue = InputBox("How many rows should the chunks be?", _
        Default:=900)
    Width = Table.Columns.Count
    Height = Table.Rows.Count
 
    'Write to array
    TableArray = Table
    ReDim TempArray(1 To CutValue, 1 To Width)
    Rep = Application.WorksheetFunction.RoundUp(Height / CutValue, 0)
    LoopReps = CutValue
 
    'Loop through all new sheets
    For Cntr = 0 To Rep - 1
        If Height - Cntr * CutValue < CutValue Then _
            LoopReps = Height - Cntr * CutValue
 
        For x = 1 To Width
            For y = 1 To LoopReps
                TempArray(y, x) = TableArray(y + Cntr * CutValue, x)
            Next y
        Next x
 
        Worksheets.Add
        Range("A1").Resize(LoopReps, Width) = TempArray
    Next Cntr
End Sub
 
Last edited:
Upvote 0
Thank you very much all. This helped me
Sub SplitWorksheet()
Dim lngLastRow As Long
Dim lngNumberOfRows As Long
Dim lngI As Long
Dim strMainSheetName As String
Dim currSheet As Worksheet
Dim prevSheet As Worksheet
'Number of rows to split among worksheets
lngNumberOfRows = 900
'Current worksheet in workbook
Set prevSheet = ThisWorkbook.ActiveSheet
'First worksheet name
strMainSheetName = prevSheet.Name
'Number of rows in worksheet
lngLastRow = prevSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Worksheet counter for added worksheets
lngI = 1
While lngLastRow > lngNumberOfRows
Set currSheet = ThisWorkbook.Worksheets.Add
With currSheet
.Move after:=Worksheets(Worksheets.Count)
.Name = strMainSheetName + "(" + CStr(lngI) + ")"
End With

With prevSheet.Rows(lngNumberOfRows + 1 & ":" & lngLastRow).EntireRow
.Cut currSheet.Range("A1")
End With

lngLastRow = currSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set prevSheet = currSheet
lngI = lngI + 1
Wend
End Sub
 
Upvote 0
Hello,

THis code is working for me but can we have this copy the cell formatting too? also if possible... can this put a header to every worksheet being created? thanks in advanced

Misha van Beek said:
Here is my version:
Code: 
Sub CopyTable()
 
    'Set dimensions
    Dim Table As Range, TableArray(), _
        CutValue As Integer, Cntr As Integer, _
        TempArray(), Width As Integer, _
        x As Integer, y As Integer, _
        Height As Long, Rep As Integer, _
        LoopReps As Long
 
    'Get data
    Set Table = Application.InputBox("Specify range to copy", _
        Default:=ActiveCell.CurrentRegion.Address, Type:=8)
    CutValue = InputBox("How many rows should the chunks be?", _
        Default:=900)
    Width = Table.Columns.Count
    Height = Table.Rows.Count
 
    'Write to array
    TableArray = Table
    ReDim TempArray(1 To CutValue, 1 To Width)
    Rep = Application.WorksheetFunction.RoundUp(Height / CutValue, 0)
    LoopReps = CutValue
 
    'Loop through all new sheets
    For Cntr = 0 To Rep - 1
        If Height - Cntr * CutValue < CutValue Then _
            LoopReps = Height - Cntr * CutValue
 
        For x = 1 To Width
            For y = 1 To LoopReps
                TempArray(y, x) = TableArray(y + Cntr * CutValue, x)
            Next y
        Next x
 
        Worksheets.Add
        Range("A1").Resize(LoopReps, Width) = TempArray
    Next Cntr
End Sub
Click to expand...
 
Upvote 0
Hy, can this code be modified in order to split the data based on specific rows? for example I want that rows from 1 to 300 to be in one worksheet, rows from 301 to 456 in another worksheet, rows from 457 to 555 in another one, rows from 556 to 653 in another one and so on. Thank you.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
VBA to Split Data From an Existing Table into Another Single Worksheet with Header for Each Section
Replies
1
Views
156
John_w
J
H
  • Question
Fixing of VBA Code
Replies
3
Views
245
jolivanes
jolivanes
C
  • Question
Named ranges from multiple sections of cells copy paste not working
Replies
6
Views
71
Alex Blakenburg
A
F
  • Solved
Macro to add sum to all worksheets in a workbook except for a certain worksheets
Replies
3
Views
250
Alex Blakenburg
A
M
  • Question
large/complicated =(Sort(Unique)) or similar
Replies
1
Views
136
KRice
K

Forum statistics

Threads
1,214,648
Messages
6,120,726
Members
448,987
Latest member
marion_davis

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top