我有一个宏,它复制一个范围,根据另一个单元格的值将该范围粘贴一定的次数到Sheet2中,但是它与循环中的每个集合重叠,而不是粘贴到列A中的下一个打开的单元格中...
这是我到目前为止所拥有的:
Dim rng As Range
Dim r As Range
Dim numberOfCopies As Integer
Dim n As Integer
Dim lastrow As Long
'## Define a range to represent ALL the data
Set rng = Sheets("Sheet1").Range("A3", Sheets("Sheet1").Range("C3").End(xlDown))
lastrow = Sheets("Sheet2").Range("A65536").End(xlUp).Row
'## Iterate each row in that data range
For Each r In rng.Rows
'## Get the number of copies specified in column 14 ("N")
numberOfCopies = r.Cells(1, 35).Value
'## If that number > 1 then make copies on a new sheet
If numberOfCopies > 1 Then
'## Add a new sheet
With Worksheets("Sheet2")
'## copy the row and paste repeatedly in this loop
For n = 1 To numberOfCopies
r.Copy .Range("A" & n)
Next
End With
End If
答案 0 :(得分:0)
尝试一下。我尚未对其进行测试,所以请告知它是否无法正常工作。
我添加了一些评论。
我认为您可以使用Resize
放弃内部循环。
Sub x()
Dim rng As Range
Dim r As Range
Dim numberOfCopies As Long 'use long rather than integer
Dim n As Long
Dim lastrow As Long
'## Define a range to represent ALL the data
With Sheets("Sheet1")
Set rng = .Range("A3", .Range("C" & Rows.Count).End(xlUp)) 'work up from the bottom rather than top down
End With
'## Iterate each row in that data range
For Each r In rng.Rows
'## Get the number of copies specified in column 14 ("N")
numberOfCopies = r.Cells(1, 35).Value
'## If that number > 1 then make copies on a new sheet
If numberOfCopies > 1 Then
'## Add a new sheet
With Worksheets("Sheet2")
'## copy the row and paste repeatedly in this loop
lastrow = .Range("A" & Rows.Count).End(xlUp).Row + 1 'want the row below last used one
r.Copy .Range("A" & lastrow).Resize(numberOfCopies)
End With
End If
End Sub