復制並粘貼到下一個空行

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