根据单元格值复制行X的次数 [英] Copy Row X amount of times based on cell value

问题描述

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

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?

例如如果 A2 包含"hello 3"，则运行宏 A3 后将包含"hello 4"， A4 将包含"hello 5"./p>

E.g. 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:

输出屏幕的外观示例:

推荐答案

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

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

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

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

这篇关于根据单元格值复制行X的次数的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！