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

该macros根据M2的单元格值复制并粘贴X行的值。 它反复粘贴确切的数字。 有没有办法改变它，以便数字会被复制下来？

例如，如果A2包含“你好3”，运行macrosA3后将包含“你好4”， A4将包含“你好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 '~~> ie 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 

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

输出屏幕应该如何显示的例子：

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

我升级我的解决scheme，使“计数器”递增

 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