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

Question

宏基于M2的单元格值复制并粘贴X行的次数。 一遍又一遍地粘贴准确的数字。 有没有一种方法可以更改它，以使数字在复制时会上升？

例如，如果A2包含“ hello 3”，则运行宏A3后将包含“ hello 4”， A4将包含“ 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

输入屏幕和输出屏幕的外观示例：

输出屏幕外观的示例：

Answer 1

如果您使用resize方法，实际上不需要j循环。

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

我升级解决方案以使“计数器”增加

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

无需内部j循环，只需升级lRow_O