复制并粘贴到下一个空行

Question

我有一个宏可以复制一个范围，根据另一个单元格值将该范围粘贴一定次数到 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

Answer 1

尝试这个。 我还没有测试过，所以如果它不能正常工作，请告诉我。

我添加了一些评论。

我认为您可以使用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