Copy content from every nth row and paste to a new worksheet.

JODomingos

New Member
Joined
Jul 11, 2020
Messages
48
Office Version
  1. 2016
Platform
  1. Windows
Hello Friends!

I need to create a macro for copying content every 8 rows and pasting to a new worksheet. For example, in the picture below I have a worksheet with all content that i need to paste to another sheet based on the criteria of 8 rows (Colored). Therefore, I would have multiple sheets, each one of them with 8 rows of the content from the main sheet. Can you help me?

Thanks in advance

1607974486581.png
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Any formulas in the rows you want copied? If yes, does the "content" you want copied include the formulas?
 
Upvote 0
See if this works for you.
VBA Code:
Sub Every8Rows()
Const HowMany As Long = 8  'number of rows to be "copied" to each new sheet
Dim wsht As Worksheet, R As Range, Ct As Long, startRw As Long, endRw As Long
Set wsht = ActiveSheet
Set R = wsht.Range("A1").CurrentRegion
Application.ScreenUpdating = False
Do
    Ct = Ct + 1
    startRw = IIf(Ct = 1, 2, endRw + 1): endRw = IIf(Ct = 1, endRw + HowMany + 1, endRw + HowMany)
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Range("A1:J1").Value = R.Rows(1).Value
    ActiveSheet.Range("A2:J9").Value = R.Rows(startRw & ":" & endRw).Value
Loop While endRw <= R.Rows.Count
wsht.Select
MsgBox Ct & " sheets have been added"
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try this:
This script assumes your values are in a sheet named "Master"
Modify sheet name if you want.
VBA Code:
Sub Copy_Rows()
'Modified  12/14/2020  4:33:26 PM  EST
Application.ScreenUpdating = False
On Error GoTo M
Dim i As Long
Dim ans As Long
Dim Lastrow As Long
Lastrow = Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
ans = Sheets.Count

For i = 2 To Lastrow Step 8
    With Sheets("Master")
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = ans
        ans = ans + 1
    .Rows(i).Resize(8).Copy Sheets(ans).Rows(2)
    End With
Next

Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "We had a problem. You may have a sheet with that name"

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

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