基於單元格值複製行X次數

Question

該宏根據M2中的單元格值複製並粘貼行X次的值。它反覆粘貼確切的數字。有沒有辦法改變它，以便數字在複製下來時會上升？

E.g.如果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

其實沒有必要j循環如果你使用resize方法。

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