Copy rows from one sheet into six sheets - excel

Question

I’ve a spreadsheet that will have a different number of rows each day.
I am trying to divide that number of rows by 6 then copy the info into six different sheets within the same workbook.
For example – say the original sheet has 3000 rows. 3000 rows divided by 6 (500), copied into six different sheets or maybe there are 2475 rows, now dividing it by 6 and trying to keep the number of record split between sheets approximately the same (keeping the sheet with the original 3000 or 2475 rows as is) within the same workbook.
I have code that is creating 6 additional sheets but the records are not being copied to these sheets.
Option Explicit
Public Sub CopyLines()
Dim firstRow As Long
Dim lastRow As Long
Dim i As Long
Dim index As Long
Dim strsheetName As String
Dim sourceSheet As Worksheet
Dim strWorkbookName As Workbook
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Set sourceSheet = Workbooks(strWorkbookName).Worksheets(strsheetName)
firstRow = sourceSheet.UsedRange.Row
lastRow = sourceSheet.UsedRange.Rows.Count + firstRow - 1
index = 1
For i = firstRow To lastRow
sourceSheet.Rows(i).Copy
Select Case index Mod 6
Case 0:
strsheetName = "Sheet1"
Case 1:
strsheetName = "Sheet2"
Case 2:
strsheetName = "Sheet3"
Case 3:
strsheetName = "Sheet4"
Case 4:
strsheetName = "Sheet5"
Case 5:
strsheetName = "Sheet6"
End Select
Worksheets(strsheetName).Cells((index / 6) + 1, 1).Paste
index = index + 1
Next i
End Sub

Answer 1

FEW THINGS:
Do not create sheets in the begining. Create them in a loop if required. This way you will not end up with blank sheets if there are only say 3 rows of data. Create them in a loop.
Also the code below assumes that you do not have Sheet1-6 beforehand. Else you will get an error at newSht.Name = "Sheet" & i
Avoid the use of UsedRange to find the last row. You may want to see see Finding last used cell in Excel with VBA
CODE:
I have commneted the code. You should not have a problem understanding the code but if you do then simply post back. Is this what you are trying?
Option Explicit
'~~> Set max sheets required
Const NumberOfSheetsRequired As Long = 6
Public Sub CopyLines()
Dim wb As Workbook
Dim ws As Worksheet, newSht As Worksheet
Dim lastRow As Long
Dim StartRow As Long, EndRow As Long
Dim i As Long
Dim NumberOfRecordToCopy As Long
Dim strWorkbookName as String
'~~> Change the name as applicable
strWorkbookName = "TMG JULY 2020 RENTAL.xlsx"
Set wb = Workbooks(strWorkbookName)
Set ws = wb.Sheets("MainSheet")
With ws
If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then
'~~> Find last row
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Get the number of records to copy
NumberOfRecordToCopy = lastRow / NumberOfSheetsRequired
'~~> Set your start and end row
StartRow = 1
EndRow = StartRow + NumberOfRecordToCopy
'~~> Create relevant sheet
For i = 1 To NumberOfSheetsRequired
'~~> Add new sheet
Set newSht = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
newSht.Name = "Sheet" & i
'~~> Copy the relevant rows
ws.Range(StartRow & ":" & EndRow).Copy newSht.Rows(1)
'~~> Set new start and end row
StartRow = EndRow + 1
EndRow = StartRow + NumberOfRecordToCopy
'~~> If start row is greater than last row then exit loop.
'~~> No point creating blank sheets
If StartRow > lastRow Then Exit For
Next i
End If
End With
Application.CutCopyMode = False
End Sub

Answer 2

Your code creates 6 sheets before it does anything with the data, which might be wasteful.
Also, once these sheets are created, there are no guarantee that they will have the names Sheet1, Sheet2, etc. These names might have already been used. That is why you should always check if the destination sheet exists before attempting to create them.
Option Explicit
Public Sub CopyLines()
Dim firstRow As Long
Dim lastRow As Long
Dim i As Long
Dim index As Long
Dim strSheetName As String
Dim sourceSheet As Worksheet
Dim strWorkbookName As String
'assume the current workbook is the starting point
strWorkbookName = ActiveWorkbook.Name
'assume that the first sheet contains all the rows
strSheetName = ActiveWorkbook.Sheets(1).Name
Set sourceSheet = Workbooks(strWorkbookName).Worksheets(strSheetName)
firstRow = sourceSheet.UsedRange.Row
lastRow = sourceSheet.UsedRange.Rows.Count + firstRow - 1
index = 1
For i = firstRow To lastRow
sourceSheet.Rows(i).Copy
Select Case index Mod 6
Case 0:
strSheetName = "Sheet1"
Case 1:
strSheetName = "Sheet2"
Case 2:
strSheetName = "Sheet3"
Case 3:
strSheetName = "Sheet4"
Case 4:
strSheetName = "Sheet5"
Case 5:
strSheetName = "Sheet6"
End Select
'check if the destination sheet exists
If Not Evaluate("ISREF('" & strSheetName & "'!A1)") Then
'if it does not, then create it
Sheets.Add
'and rename it to the proper destination name
ActiveSheet.Name = strSheetName
End If
'now paste the copied cells using PasteSpecial
Worksheets(strSheetName).Cells(Int(index / 6) + 1, 1).PasteSpecial
'advance to the next row
index = index + 1
'prevent Excel from freezing up, by calling DoEvents to handle
'screen redraw, mouse events, keyboard, etc.
DoEvents
Next i
End Sub

Answer 3

Try the next code, please. It uses arrays and array slices and it should be very fast:
Sub testSplitRowsOnSixSheets()
Dim sh As Worksheet, lastRow As Long, lastCol As Long, arrRows As Variant, wb As Workbook
Dim arr As Variant, slice As Variant, SplCount As Long, shNew As Worksheet
Dim startSlice As Long, endSlice As Long, i As Long, Cols As String, k As Long
Const shtsNo As Long = 6 'sheets number to split the range
Set wb = ActiveWorkbook 'or Workbooks("My Workbook")
Set sh = wb.ActiveSheet 'or wb.Sheets("My Sheet")
lastRow = sh.Range("A" & rows.count).End(xlUp).row 'last row of the sheet to be processed
lastCol = sh.UsedRange.Columns.count 'last column of the sheet to be processed
arr = sh.Range(sh.Range("A2"), sh.cells(lastRow, lastCol)) 'put the range in an array
SplCount = WorksheetFunction.Ceiling_Math(UBound(arr) / shtsNo) 'calculate the number of rows for each sheet
Cols = "A:" & Split(cells(1, lastCol).Address, "$")(1) 'determine the letter of the last column
clearSheets wb 'delete previous sheets named as "Sheet_" & k
For i = 1 To UBound(arr) Step SplCount 'iterate through the array elements number
startSlice = i: endSlice = i + SplCount - 1 'set the rows number to be sliced
'create the slice aray:
arrRows = Application.Index(arr, Evaluate("row(" & startSlice & ":" & endSlice & ")"), _
Evaluate("COLUMN(" & Cols & ")"))
'insert a new sheet at the end of the workbook:
Set shNew = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count))
shNew.Name = "Sheet_" & k: k = k + 1 'name the newly created sheet
If UBound(arr) - i < SplCount Then SplCount = UBound(arr) - i + 1 'set the number of rows having data
'for the last slice
shNew.Range("A2").Resize(SplCount, lastCol).value = arrRows 'drop the slice array at once
Next i
End Sub
Sub clearSheets(wb As Workbook)
Dim ws As Worksheet
For Each ws In wb.Worksheets
If left(ws.Name, 7) Like "Sheet_#" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
End Sub

Answer 4

Try this following code. It streams through data and adds sheets dynamically, renames them according to the row# , copies the headers from the first row and the data block needed.
Public Sub DistributeData()
Const n_sheets As Long = 6
Dim n_rows_all As Long, n_cols As Long, i As Long
Dim r_data As Range, r_src As Range, r_dst As Range
' First data cell is on row 2
Set r_data = Sheet1.Range("A2")
' Count rows and columns starting from A2
n_rows_all = Range(r_data, r_data.End(xlDown)).Rows.Count
n_cols = Range(r_data, r_data.End(xlToRight)).Columns.Count
Dim n_rows As Long, ws As Worksheet
Dim n_data As Long
n_data = n_rows_all
' Get last worksheet
Set ws = ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets().Count)
Do While n_data > 0
' Figure row count to copy
n_rows = WorksheetFunction.Min(WorksheetFunction.Ceiling_Math(n_rows_all / n_sheets), n_data)
' Add new worksheet after last one
Set ws = ActiveWorkbook.Worksheets.Add(, ws, , XlSheetType.xlWorksheet)
ws.Name = CStr(n_rows_all - n_data + 1) & "-" & CStr(n_rows_all - n_data + n_rows)
' Copy Headers
ws.Range("A1").Resize(1, n_cols).Value = _
Sheet1.Range("A1").Resize(1, n_cols).Value
' Skip rows from source sheet
Set r_src = r_data.Offset(n_rows_all - n_data, 0).Resize(n_rows, n_cols)
' Destination starts from row 2
Set r_dst = ws.Range("A2").Resize(n_rows, n_cols)
' This copies the entire block of data
' (no need for Copy/Paste which is slow and a memory hog)
r_dst.Value = r_src.Value
' Update remaining row count to be copied
n_data = n_data - n_rows
' Go to next sheet, or wrap around to first new sheet
Loop
End Sub
Do not use Copy/Paste as it is slow and buggy. It is always a good idea to directly write from cell to cell the values. You can do that for an entire table of cells (multiple rows and columns) with one statement like in the example below:
ws_dst.Range("A2").Resize(n_rows,n_cols).Value = _
ws_src.Range("G2").Resize(n_rows,n_cols).Value

Answer 5

Sub split()
On Error Resume Next
Application.DisplayAlerts = False
Dim aws As String
Dim ws As Worksheet
Dim wb As Workbook
Dim sname()
sname = Array("one", "two", "three", "four", "five", "six")
aws = ActiveSheet.Name
For Each ws In Worksheets
If ws.Name = "one" Then ws.Delete
If ws.Name = "two" Then ws.Delete
If ws.Name = "three" Then ws.Delete
If ws.Name = "four" Then ws.Delete
If ws.Name = "five" Then ws.Delete
If ws.Name = "six" Then ws.Delete
Next ws
lr = (Range("A" & Rows.Count).End(xlUp).Row) - 1
rec = Round((lr / 6), 0)
Set ws = ActiveSheet
f = 1
t = rec + 1
i = 1
While i <= 6
Sheets.Add.Name = sname(i - 1)
Sheets(aws).Select
If i = 6 Then
Range("A" & (f + 1), "A" & (lr + 1)).Select
Else
Range("A" & (f + 1), "A" & t).Select
End If
Selection.Copy
Sheets(sname(i - 1)).Select
Range("A2").Select
ActiveSheet.Paste
Cells(1, 1).Value = ws.Range("A1").Value
f = f + rec
t = t + rec
i = i + 1
Wend
End Sub