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.

Before Macro.jpg After Macro.jpg

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