根据单元格值复制粘贴单独的数据范围

Question

我在第 1、2、3 和 4 行中有 A:Q 列的数据范围。我正在尝试创建一个 VBA，因此它执行以下操作：

复制第 1 行 A:Q，从单元格 A17 开始，根据单元格 O12 拖动并粘贴 n 行。

复制第 2 行 A:Q，根据单元格 O12 拖动并粘贴 n 行，但粘贴范围应在第 1 行范围粘贴的内容之后。

重复第 3 行和第 4 行。

所以对于单元格 O12 状态 4，我应该得到 16 行 4 每一行被拖下来。

任何帮助将不胜感激。

Sub CopyJournalLines()

' Works out last cell with data in columns A or B, copys row 2 and paste within that range (from startrow)

Dim ws As Worksheet
Dim rng1 As Range
Dim LastRow As String
Dim StartRow As String
Dim Copyrange As String
Dim LastYRow As String

Application.ScreenUpdating = False

' Find the last row of data on Concur Extract sheet

Set ws = Sheets("Invoicing")
Set rng1 = ws.Columns("A:B").Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)

' Setting range on Test to copy formulas accross into

StartRow = 17
LastRow = rng1.Row + 1
LastYRow = rng1.Row + 2

If LastYRow < 21 Then
    LastYRow = 19
End If

Set ws = Sheets("Vision Import Sheet")
Let Copyrange = StartRow & ":" & LastRow
Let LastYCell = "AB" & LastYRow

' Clear previous content - limited to clear first 1000rows

Rows("17:5000").Cells.Clear
'Selection.ClearContents

If LastRow < 17 Then
    GoTo End1
End If

' Copying & pasting  row with correct formulas

Rows("1:5").Select
Selection.EntireRow.Hidden = False

Rows("1:1").Select
Selection.Copy

Rows("17:17").Select
ActiveSheet.Paste

Rows("17:17").Select
Selection.Replace What:="#", Replacement:="=", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Rows("17:17").Select
Selection.Copy

Rows(Copyrange).Select
ActiveSheet.Paste

Rows("1:5").Select
Selection.EntireRow.Hidden = True

End1:
Application.CutCopyMode = False    
Application.ScreenUpdating = True

End Sub

Answer 1

复制/粘贴方法应该放在两个循环中，对应两个参数：要复制的行数和每行的复制数。

对于以下代码，您可以通过注释和取消注释计算 iCopyRow 参数的两行来选择以格式 111222333 或格式 123123123 进行复制。

Sub CopyJournalLines2()
    Dim wsInv As Worksheet
    Dim i As Integer
    Dim j As Integer
    Dim iStartRow As Integer
    Dim iNumCopies As Integer
    Dim iNumLines As Integer
    Dim iCopyRow As Integer
    Dim CopyRange As Range
    Dim PasteRange As Range

    Set wsInv = ThisWorkbook.Sheets("Invoice Upload")

    With wsInv
        .Rows("17:5000").Cells.Clear
        iStartRow = 17
        iNumCopies = .Range("O12").Value
        iNumLines = .Range("P12").Value
        For i = 1 To iNumLines
            Set CopyRange = .Range(.Cells(i, 1), .Cells(i, 17))
            iCopyRow = iStartRow + (i - 1) * iNumCopies '---Copies lines in order 111222333444 etc.
            'iCopyRow = iStartRow + (i - 1) '---Copies lines in order 123412341234 etc.
            Set PasteRange = .Range(.Cells(iCopyRow, 1), .Cells(iCopyRow, 17))
            PasteRange.Formula = CopyRange.Formula

            If iNumCopies > 1 Then
                For j = 2 To iNumCopies
                    iCopyRow = iStartRow + j - 1 + (i - 1) * iNumCopies '---Copies lines in order 111222333444 etc.
                    'iCopyRow = iStartRow + i - 1 + ((j - 1) * iNumLines) '---Copies lines in order 123412341234 etc.
                    .Range(.Cells(iCopyRow, 1), .Cells(iCopyRow, 17)).Formula = PasteRange.Formula

                Next j
            End If
        Next i
    End With
End Sub