Copy every 6th row and insert/paste underneath. Duplicate every 6th row on same sheet.

[jsherst]

Hello,

I need a Macro to copy every 6th row (starting at 1) and insert underneath said row. It would look something like this:

1 Black
2 Blue
3 Gold
4 Green
5 Orange
6 Red
7 Black
8 Blue
9 Gold
10 Green
11 Orange
12 Red

Needs to be:

1 Black
1 Black
2 Blue
3 Gold
4 Green
5 Orange
6 Red
7 Black
7 Black
8 Blue
9 Gold
10 Green
11 Orange
12 Red

And repeat this for the entire sheet. If someone can explain what the number variables do in their code I would be able to alter it for my different uses. Sometimes I will need it to duplicate the 6th row, sometimes the 4th, etc.

I have this code that does somethign similar. I can copy every row 'x' number of times. It may be able to be altered to do what I need. It has been so long since I used excel that I have forgotten what each variable does

Sub insertrows()
MyColumn = "A"
For x = Cells(Rows.Count, MyColumn).End(xlUp).Row To 1 Step -1
       Rows(x).Copy
       Rows(x).Resize(6).Insert
Next x
End Sub

 

[jsherst]

Awesome! These both work perfectly.

I will have a good time deciphering how each one was coded.

Thanks again guys!

 

[yangc10]

I don't know if this is what you're looking for, but hope it point you to the right direction.

Sub Test()
Sheets("Sheet1").Select
Range("A1:A6").Select
Selection.Copy
    
If Application.WorksheetFunction.CountA("A:A") = 0 Then
[A1].Select
Else
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeBlanks)(1, 1).Select
ActiveSheet.Paste
If Err <> 0 Then
On Error GoTo 0
[A65536].End(xlUp)(2, 1).Select
ActiveSheet.Paste

End If
On Error GoTo 0
End If
End Sub

 

[gior]

Is formula actual?
Assuming first cell with data is A1.
Formula in C1:

=OFFSET($A$1, ROW()-1- INT((ROW()/7)),0)

Extend formula.

 

[jsherst]

Sub addrows()

Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
'work out your startrow

For x = 6 To Finalrow 'my startrow was 6
Cells(x, 1).Copy
x = x + 1
Cells(x, 1).Insert
x = x + 5
Next x

End Sub

Hmm, just noticed.

Is there any way to extend this formula past a single column? I essentially need it to go from column A to column BQ

Also, it seems to stop at the original final row (1580), it inserted many rows along the way so the actual ending row is around 1800 something. The vb code will stop at exactly 1580, leaving the rest out.

 

[Peter_SSs]

Also, it seems to stop at the original final row (1580), it inserted many rows along the way so the actual ending row is around 1800 something. The vb code will stop at exactly 1580, leaving the rest out.

That is one reason why when inserting (or deleting) rows, it is better to start at the bottom and work upwards, as I had mentioned early in the thread.

Did you try my code from post #10? (It may also resolve your other question above)

 

[jsherst]

Thanks. Try this in a copy of your workbook.

Sub insertrows()
  Dim StartRow As Long, r As Long
   
  Const MyColumn As String = "A"  '<- Column of interest
  Const Gap As Long = 6           '<- Row multiple to repeat
  
  StartRow = Cells(Rows.Count, MyColumn).End(xlUp).Row
  StartRow = StartRow - StartRow Mod Gap + 1
  Application.ScreenUpdating = False
  For r = StartRow To 1 Step -Gap
    Rows(r).Copy
    Rows(r).Insert
  Next r
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

Thank you Peter. Tried this again on the full workbook and it looks like its working perfectly. It indeed copies all columns as well, within the range I selected.

 

[Dryver14]

Peter,

That's why I love this site, people take my VBA baby talk and turn it into real language, who knew about Mod? I do now....Thanks