Question

对于列A：Q，我在行1,2,3和4中有数据范围。我正在尝试创建一个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

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

1 个答案: