VBA - Copy & insert the currently selected row of data multiple times

[Scawtt]

Hello new to VBA here and spent a great deal trying to search and figure this out myself but cannot.


I want to create a macro in excel that copies the currently active cells row and inserts it a number of times below by the currently selected cell and then changes whatever the number was to a 1. I have attached a before and after example below of what I am after.

31651 31652

I managed to find a code on this site which I changed slightly which can do the first part of my problem but not the second part of changing the specified number to a 1.


Sub DuplicateRow()
Dim NextRow As Long
Dim NrOfCopies As Long
Dim i As Long
' Dont think I need this? '
Const NrOfCopiesDefault = 1
Const NrOfCopiesMaximum = 1000

Do
' I believe this selects the cell to start at and the number of copies to make '
On Error Resume Next
NrOfCopies = ActiveCell - 1
On Error GoTo 0
' Dont think I need this'
If NrOfCopies = 0 Then
MsgBox "No copies made.", vbInformation, "CANCELLED"
Exit Sub
End If

Loop While NrOfCopies < 1 Or NrOfCopies > NrOfCopiesMaximum
' I assume this is the code to insert new rows and copy said row down a number of times '
With Selection
NextRow = .Row + .Rows.Count
Rows(NextRow & ":" & NextRow + .Rows.Count * (NrOfCopies) - 1).Insert Shift:=xlDown
.EntireRow.Copy Rows(NextRow & ":" & NextRow + .Rows.Count * (NrOfCopies) - 1)
.Resize(.Rows.Count * (NrOfCopies + 1)).Sort key1:=.Cells(1, 1)
End With
' I want to put in code to change the number in each copied row to a 1 here? '
End Sub


I'd me more than ok to edit the code above or start fresh. Also would love to add descriptive titles like in my code so I can understand what the code means for future reference as I love to learn new things. Thank you for your help.

[georgiboy]

Hi Scawtt,

Welcome to the forum.

Out of interest, which version of Excel do you use: 2016, 2021, 365?

If you are using Excel 365 for example then the below will do it:

Sub Test()
Dim r As Long, str As String, rpt As Long, s As Variant

r = ActiveCell.Row
str = Cells(r, 1)
rpt = Cells(r, 2)

Rows(r + 1 & ":" & r + (rpt - 1)).Insert
With Application
s = .Sequence(rpt, , 1, 0)
Cells(r, 1).Resize(rpt) = .Rept(str, s)
Cells(r, 2).Resize(rpt) = s
End With
End Sub

[georgiboy]

Just noticed that you wanted annotations:

Sub Test()
Dim r As Long, str As String, rpt As Long, s As Variant

r = ActiveCell.Row ' assign "r" to be the active row
str = Cells(r, 1) ' '"str" becomes the value in column A (column One) of the active row
rpt = Cells(r, 2) ' '"rpt" becomes the value in column B (column Two) of the active row

' inserts ("rpt" less one) rows under the active row ("r")
' So: (active row + 1) to (active row + (rpt - 1))
' This means that the count of active row and the newly inserted rows will be equal to "rpt" rows
Rows(r + 1 & ":" & r + (rpt - 1)).Insert


With Application ' saves me typing Application over and over, anything that starts with "." now refers to Application
' creates an array with "rpt" amount of rows, the sequence starts at 1 and the step to the sequence is 0, therefore we get an array with "rpt" amount of 1's
s = .Sequence(rpt, , 1, 0)
' resizes the range: column one active row to be "rpt" amount of rows starting at the active row
' the .Rept part repeats the "str" once for every time there is a one in the sequence of 1's we created in the array "s"
' so the resized range now = the array of "str" we created
Cells(r, 1).Resize(rpt) = .Rept(str, s)
' resizes the range: column two active row to be "rpt" amount of rows starting at the active row
' as "s" is now just an array of 1's with a count of "rpt" we can just make the resized range = "s"
Cells(r, 2).Resize(rpt) = s
End With
End Sub