根据单元格值复制行X的次数

Question

The macro copies and pastes the values of a row X amount of times based on a cell value in M2 . It pastes the exact numbers over and over. Is there a way to change it so that numbers will ascend as they are copied down?

Eg if A2 contains "hello 3", after running the macro A3 will contain "hello 4", A4 will contain "hello 5".

Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow_I As Long, lRow_O As Long, i As Long, j As Long

'~~> Set your input and output sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet1")

'~~> Output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1

With wsI
    '~~> Get last row of input sheet
    lRow_I = .Range("A" & .Rows.Count).End(xlUp).Row

    '~~> Loop through the rows
    For i = 2 To lRow_I
        '~~> This will loop the number of time required
        '~~> i.e the number present in cell M
        For j = 1 To Val(Trim(.Range("M" & i).Value))
            '~~> This copies
            .Rows(i).Copy wsO.Rows(lRow_O)
            '~~> Get the next output row
            lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
        Next j
    Next i
End With
End Sub

Example of how input screen and output screen should look:

Example of how output screen should look:

Answer 1

Actually no need for j loop if you use resize method.

Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet, lCounter As Long
Dim lRow_I As Long, lRow_O As Long, i As Long

Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")

With wsI
    lCounter = Val(Trim(.Range("M" & i).Value))
    lRow_I = .Range("A" & .Rows.Count).End(xlUp).Row

    For i = 2 To lRow_I
        lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
        .Rows(i).Copy wsO.Rows(lRow_O).Resize(lCounter)
    Next i

End With

Answer 2

I upgrade my solution to have the "counter" incremented

Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow_I As Long, lRow_O As Long, i As Long, nRowsToPaste As Long
Dim rngToCopy As Range, rngToPaste As Range

'~~> Set your input and output sheets
Set wsI = ThisWorkbook.Sheets("SheetI")
Set wsO = ThisWorkbook.Sheets("SheetO") '<=== I made it different that wsI

'~~> Output row
lRow_O = wsO.Range("A" & wsO.Rows.Count).End(xlUp).row + 1
With wsI
    '~~> Get last row of input sheet
    lRow_I = .Range("A" & .Rows.Count).End(xlUp).row

    '~~> Loop through the rows
    For i = 2 To lRow_I
        nRowsToPaste = val(Trim(.Range("M" & i).Value)) '<== set number of rows to be pasted

        Set rngToCopy = .Range(.Cells(i, 1), .Cells(i, wsI.Columns.Count).End(xlToLeft)) '<== set range to be copied
        Set rngToPaste = wsO.Rows(lRow_O).Resize(1, rngToCopy.Columns.Count)             '<== set 1st row of the range to be pasted

        rngToCopy.Copy rngToPaste      '<== copy&paste the 1st row in wsO sheet                                                        '<== copy and paste the 1st row
        Call Prefix(rngToPaste) '<== differentiate each single cell of pasted range by means of adding a different prefix. this will subsequently have autofill method work on cells with originally the same value as well

        With rngToPaste
            .AutoFill .Resize(nRowsToPaste + 1) ' <== fill all rows exploiting AutoFill method, which will work on every column being their 1st row different from each other
            .Resize(nRowsToPaste + 1).Replace What:="%%*%%", Replacement:="", LookAt:=xlPart '<== remove prefix
        End With

        lRow_O = lRow_O + nRowsToPaste + 1 '<== GET the next output row

    Next i

End With
End Sub

Sub Prefix(rng As Range)
Dim j As Long
With rng
    For j = 1 To .Columns.Count
        .Cells(1, j).Value = "%%" & j & "%%" & .Cells(1, j).Value
    Next j
End With
End Sub

where it eliminates the need of the inner j-loop and simply upgrades the lRow_O