Copy rows from one sheet into six sheets

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

That's fairly easy, what have you tried? Where is your code? Are you getting errors? — Damian, Sep 14 '20 at 08:25
@Damian Just edited my question and added the code Please have a look at it — Kartik Singh, Sep 14 '20 at 08:39

Siddharth Rout · Answer 1 · 2020-09-14T11:02:39.953

0

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

edited Sep 14 '20 at 11:02

answered Sep 14 '20 at 09:06

Siddharth Rout

147,039
17
206
250

This macro is giving an error Run-time Error '9': Subscript out of range – Kartik Singh Sep 14 '20 at 09:15
Did you change `MainSheet` to the relevant sheet name? Also I saw some typos. Have fixed it. You may have to refresh the page to see it... – Siddharth Rout Sep 14 '20 at 09:29
Still showing same error, can it be because of the version I'm using?? Office 365 And I also changed name of my sheet to MainSheet – Kartik Singh Sep 14 '20 at 09:39
Where are you running this code from? From the workbook which the sheet "MainSheet" and whose data needs to be split? – Siddharth Rout Sep 14 '20 at 09:54
Yes, from the same workbook that contains the MainSheet. – Kartik Singh Sep 14 '20 at 10:04
May I see the file? Btw which line is giving you the error? – Siddharth Rout Sep 14 '20 at 10:10
IS there a way so that I can share a Screenshot or something? – Kartik Singh Sep 14 '20 at 10:16
You can but first tell me which line is giving you the error? – Siddharth Rout Sep 14 '20 at 10:19
I'm new to this VBA thing and this is not a regular task for me So I cannot specify which line is giving error. But once I select the option to debug on the dialog box The following line is displayed with yellow highlight: Set ws = ThisWorkbook.Sheets("MainSheet") – Kartik Singh Sep 14 '20 at 10:23
Thought so. If you are getting `Subscript out of range` error then it means that it is not able to find the sheet. This is the reason why I wanted to see your workbook. Feel free to delete all data from the file and then share the file? – Siddharth Rout Sep 14 '20 at 10:27
how can I share the file can you please help me regarding that? – Kartik Singh Sep 14 '20 at 10:33
www.wikisend.com or dropbox or onedrive – Siddharth Rout Sep 14 '20 at 10:40
https://drive.google.com/file/d/1ZdEeuCGdEh3C3K-MNOgbKLYeW7eY42ja/view?usp=sharing Please let me of it is accessible or not – Kartik Singh Sep 14 '20 at 10:43
Are you running the code from `TMG JULY 2020 RENTAL.xlsx` or some other file? – Siddharth Rout Sep 14 '20 at 10:44
I have a seprate file for macros. I won't be able to share that – Kartik Singh Sep 14 '20 at 10:46
No i do not need that file. I finally undersood what the problem is.. updating the code. – Siddharth Rout Sep 14 '20 at 10:47
I have updated the code. The code was looking for the sheet in the workbook from where the code was running. Add the workbook object `Set wb = Workbooks(strWorkbookName)` Now try the code. Please do not just copy and paste the code. Understand what the code is doing. You may have to refresh the page to see the changes... – Siddharth Rout Sep 14 '20 at 10:53
It's working now But the thing is that The order of sheets are as follows: Sheet6>Sheet5>...>Sheet1>MainSheet The records in MainSheet are 397 The records per each sheet are 67 Work fine for me But data is visible in all the sheets, except for Sheet1 – Kartik Singh Sep 14 '20 at 10:58
Updated the post. Now try it – Siddharth Rout Sep 14 '20 at 11:02

FaneDuru · Answer 2 · 2020-09-15T12:31:55.197

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

Btw when I'm using this macro do I need to change the sheet name to any specific or will it pick data from any sheet(irrespective of the name)? — Kartik Singh, Sep 14 '20 at 11:07
@Kartik Singh: Glad I could help! It will pick data from any sheet, if you properly qualify it. I mean, you should replace `Set sh = ActiveSheet` with `Set sh = Worksheets("The one you want")`. But you must understand that in this way **everything refers to the active workbook**. If you want to work with a sheet of an inactive workbook you have to use `Set sh = Workbooks("Your workbook").sheets("Your worksheet")`. And also take care to add new sheets to the same workbook... If needed I can adapt the code to firstly define the workbook to be used. — FaneDuru, Sep 14 '20 at 11:14
Thanks a lot for this particular detail, I'll surely keep it in mind. And would love to connect with you if I get myself stuck with some problem in future. — Kartik Singh, Sep 14 '20 at 11:19
@Kartik Singh: I adapted the code to be able to work with any open workbook (`wb`)... But we here, when somebody answer our question, tick the left code side check box, in order to make it **accepted answer**. In this way, somebody else searching for a similar issue, will know that the code works... — FaneDuru, Sep 14 '20 at 11:20
@Kartik Singh: Didn't the above code solve your problem? I also added a sub to be used for deleting the previous created worksheets, if you need to re run the code... — FaneDuru, Sep 15 '20 at 12:33

score 0 · Answer 3 · answered Sep 14 '20 at 11:10

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

score 0 · Answer 4 · answered Sep 15 '20 at 17:00

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

score -1 · Answer 5 · answered Sep 14 '20 at 11:06

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

Try this code if this help ... you should run this code from the main sheet where you want to split the data .... — Radhish Thekkute, Sep 14 '20 at 11:07
-1 [for using `.Select`](https://stackoverflow.com/q/10714251/13813219) and for doing string math as in `Range("A" & (f + 1), "A" & (lr + 1))`. It is much better to use the existing functionality of `Range` objects suich as `.Offset()`, `.Resize()` and `.Cells()` to make more maintainable code and avoiding absolute referencing, — JAlex, Sep 15 '20 at 17:04

Copy rows from one sheet into six sheets

5 Answers5