Split Every N Rows From Worksheet Into New Worksheets

[supermat]

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.

 

[texasalynn]

Welcome to MrExcel Board!

take a look at this
http://www.mrexcel.com/forum/showthread.php?t=355323

 

[Domski]

Try something like:

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

 

[supermat]

Can we make this be worksheets in the same workbook instead of new workbooks?

 

[Domski]

Sure:

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

 

[supermat]

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

 

[Misha van Beek]

Here is my version:

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

 

[Dilip Darapureddy]

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

 

[jeremiah_j2k]

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

Here is my version:

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

 

[prv_mihai]

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.