VBA - 复制，粘贴然后移动到下一行直到到达空白

Question

基本上，我在三列中有数据，在单独的选项卡上有一个模型。数据选项卡有 1000 行数据，每个条目都将在模型中运行，结果将粘贴到第四列。

这是一次迭代的样子，但我需要它遍历每一行。

Worksheets("Data").Range("E2:G2").Copy _ 
Worksheets("Model").Range("B4:D4").PasteSpecial Paste:=xlPasteValues

Calculate

Worksheets("Model").Range("C120").Copy_
Worksheets("Data").Range("H2").PasteSpecial Paste:=xlPasteValues

Worksheets("Model").Range("C121").Copy_
Worksheets("Data").Range("I2").PasteSpecial Paste:=xlPasteValues

Worksheets("Model").Range("C122").Copy_ 
Worksheets("Data").Range("J2").PasteSpecial Paste:=xlPasteValues

然后我们会从“数据”选项卡中复制下一行数据（即范围 E3:G3）。

这似乎是一个经典的循环场景，但我不知道如何用 VBA 编写它。

Answer 1

您可以在一个范围内执行此操作，我看到有两种方法可以执行此操作，使用复制和粘贴或简单地复制数据的转置版本：

'Copy and paste method
Worksheets("Model").Range("C120:C" & range("C" & rows.count).end(xlup).row).Copy 'Using the .end(xlup) will find the last row of data without looping until blank.
Worksheets("Data").Range("H2").PasteSpecial xlPasteValues,,,True 'The True here is what tells the pastespecial to transpose

'Transpose method
Worksheets("Data").Range("H2:J2").Value = application.transpose(Worksheets("Model").range("C120:C122"))

每个都有自己的优势，复制和粘贴方法更容易，因为您不需要知道结束列，因此它更容易用于动态范围，转置方法不使用剪贴板，因此对您的影响较小系统。

在代码方面更好的方法是转置方法。

然后，您可以设置一个简单的For Next 循环来遍历任意数量的数据范围。

Dim DataRow As Long, MyDat As Worksheet, MyModel As Worksheet
Set MyDat = Worksheets("Data")
Set MyModel = Worksheet("Model")
For DataRow = 2 To MyDat.Range("E" & Rows.Count).End(xlUp).Row
    MyModel.Range("B4:D4").Value = MyDat.Range("E" & DataRow & ":G" & DataRow).value
    Calculate
    MyDat.Range("H" & DataRow & ":J" & DataRow).Value = Application.Transpose(MyModel.Range("C120:C122"))
Next

Answer 2

这是一个简单的循环，它找到“数据”中的最后一行并将其用于“模型”中定义的循环。

这样的预期结果是循环将从第 120 行开始并一直持续到“数据”中的最后一行，将数据从 C120 复制到 C(lRow) 并将其粘贴到“数据”表中。

Sub test()
    ' declare your variables so vba knows what it is working with
    Dim lRow, i As Long
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim srcws As Worksheet: Set srcws = wb.Worksheets("Data")
    Dim destws As Worksheet: Set destws = wb.Worksheets("Model")

    ' find the last row in Data
    lRow = srcws.Cells(srcws.Rows.Count, 1).End(xlUp).Row

    ' iterate from 120 to the last row found above
    For i = 120 To lRow
        ' copy /paste the data
        srcws.cells(1, 3).Copy Destination:=destws.cells(2, 7 + i)
    Next i
End Sub

Answer 3

最好的方法是使用单元格函数，其中第一个参数是行，第二个是列。由于您希望一次将要复制的源增加一行，但一次将粘贴目标增加一列，因此此方法将是合适的。

另外，尽量不要使用“复制粘贴”，重点是通过引用源中的值属性来设置单元格的值进行复制。每次复制然后粘贴到目标位置时，您都需要一个额外的存储单元，如果您要复制的范围很大，则需要更长的时间。

下面的代码应该可以完成这项工作。

Sub CopyData()
    Dim i As Integer
    i = 8 ' Start pasting into column H
    ' Loop until a blank cell is found
    Do While Not Selection.Value = 0
        With Sheets("Data").Cells(i + 112, 3)
            ' Select each cell in "Data", starting on C120
            .Select
            ' Copy the value into "Model", starting on H2
            Sheets("Model").Cells(2, i).Value = .Value
        End With
    Loop
End Sub