[英]Copy Row X amount of times based on cell value
宏基於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
輸入屏幕和輸出屏幕的外觀示例:
輸出屏幕外觀的示例:
如果您使用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
我升級解決方案以使“計數器”增加
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.