vba - 在 Excel 中，如何生成行 X 次的副本？

Question

在 Excel 中，我需要为批量上传生成文件，其中包含 1K、5K、10K 和 100K 行。所以我查看了 VBA 脚本。下面是:

Private Sub CommandButton21_Click()

    ' This routing will copy rows based on the quantity to a new sheet.
    Dim rngSinglecell As Range
    Dim rngQuantityCells As Range
    Dim intCount As Integer

    ' Set this for the range where the Quantity column exists. This works only if there are no empty cells
    Set rngQuantityCells = Range("D1", Range("D1").End(xlDown))

    For Each rngSinglecell In rngQuantityCells
        ' Check if this cell actually contains a number
        If IsNumeric(rngSinglecell.Value) Then
            ' Check if the number is greater than 0
            If rngSinglecell.Value > 0 Then
                ' Copy this row as many times as .value cut out rngSinglecell DOT Value
                For intCount = 1 To 1000
                    ' Copy the row into the next emtpy row in sheet2
                    Range(rngSinglecell.Address).EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    ' The above line finds the next empty row.

                Next
            End If
        End If
    Next

End Sub

但我想要做的是复制来自 A15 的一行数据。至 Y15 ，然后将其粘贴到工作表中，以便我可以将其复制粘贴回原始工作表(用于 iProcurement 中的批量上传)。

出于某种原因，我的行只被复制了两次，即使我将 intcount 更改为以下内容:

For intCount = 1 To 1000

任何提示表示赞赏，谢谢!

Answer 1

据我所知，您正在尝试这样做-

Sub test()
    ' This routing will copy rows based on the quantity to a new sheet.

    Dim lastrow As Integer
    lastrow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row

    ' Set this for the range where the Quantity column exists. This works only if there are no empty cells

    Dim destlastrow As Integer
    destlastrow = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
    ' The above line finds the next empty row.
    For i = 1 To lastrow
        ' Check if this cell actually contains a number
        If IsNumeric(Cells(i, 4)) Then
            ' Check if the number is greater than 0
            If Cells(i, 4) > 0 Then
                ' Copy this row as many times as .value cut out rngSinglecell DOT Value
                For j = 1 To Cells(i, 4).Value
                    ' Copy the row into the next emtpy row in sheet2
                    Cells(i, 4).EntireRow.Copy Destination:=Sheets("Sheet2").Cells(destlastrow, 1)
                    destlastrow = destlastrow + 1

                Next
            End If
        End If
    Next

End Sub