Vba 根据单元格值复制/粘贴X次
我想复制整行并将值粘贴到另一个工作表中 即Vba 根据单元格值复制/粘贴X次,vba,excel,Vba,Excel,我想复制整行并将值粘贴到另一个工作表中 即 第1行将是标题 第2行将包含要复制的数据 第3行与上述第2行相同 重复下来 在数据行中,列M中有一个单元格,其中包含一个数字,该数字可以为每行更改,因此这将更改粘贴时间 我想复制并粘贴行中的完整数据,比如2,按M2中显示的数字。如果M2具有4,则从第1页开始的第2行将被复制到第2页,一行比另一行低四倍 表1有16列数据,如下所示 Aa Bb Cc Dd Ee Ff Gg Hh Ii Gg Kk Ll **4** Nn Oo Pp 当宏运行时,它将如图
M
中有一个单元格,其中包含一个数字,该数字可以为每行更改,因此这将更改粘贴时间
我想复制并粘贴行中的完整数据,比如2,按M2中显示的数字。如果M2
具有4
,则从第1页开始的第2行将被复制到第2页,一行比另一行低四倍
表1有16列数据,如下所示
Aa Bb Cc Dd Ee Ff Gg Hh Ii Gg Kk Ll **4** Nn Oo Pp
当宏运行时,它将如图2中所示
Aa Bb Cc Dd Ee Ff Gg Hh Ii Gg Kk Ll **4** Nn Oo Pp<br>
Aa Bb Cc Dd Ee Ff Gg Hh Ii Gg Kk Ll **4** Nn Oo Pp<br>
Aa Bb Cc Dd Ee Ff Gg Hh Ii Gg Kk Ll **4** Nn Oo Pp<br>
Aa Bb Cc Dd Ee Ff Gg Hh Ii Gg Kk Ll **4** Nn Oo Pp<br>
唯一的问题是它只复制前4列。但我要复制整行。目前共有16列,但未来可能会增长 其实很简单。试试这个(未经测试)
Sub CopyRowsXTimes()
Dim rngCell As Range
ThisWorkbook.Worksheets("Sheet2").Cells.ClearContents
For Each rngCell In ThisWorkbook.Worksheets("Sheet1").Range("N2:N" & _
Cells(Rows.Count, 14).End(xlUp).Row)
With ThisWorkbook.Worksheets("Sheet2")
.Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, _
1).Resize(rngCell.Value, 5).Value = rngCell.Offset(, -3).Resize(1, 5).Value
End With
Next rngCell
Set rngCell = Nothing
End Sub
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("Sheet2")
'~~> 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