VBA复制粘贴到新工作表，If语句和转置

Question

当列 D 等于“Y”时，我从列 E1:F1 复制行。在 Sheet2 中以转置格式粘贴。循环直到 Sheet1 的 D 列结束。当我编辑代码以粘贴到 G12（而不是 A1）时，它会将值相互粘贴，而不是向下到 G 列中的下一个空白单元格。

我不知道代码哪里错了。请帮忙！

Sub CopyPaste3()

Dim row As Integer
Dim lastrow As Integer
Dim r As Integer
Dim S1 As Worksheet
Dim S2 As Worksheet


Set S1 = Worksheets("Sheet1")
Set S2 = Worksheets("sheet2")
row = 1
rowg = 12
lastrow = S1.Range("A" & Rows.Count).End(xlUp).row

For r = 2 To lastrow
    If S1.Range("D" & r).Value = "Y" Then
        S1.Range("E1:F1").Rows(r).Copy

        S2.Activate
        S2.Cells(12, 7).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        rowg = S2.Range("G" & Rows.Count).End(xlUp).row + 1
    End If
Next r
End Sub 

Answer 1

详述Avoid using Select。

使用Select、Copy 和Paste 等方法很容易阅读和可视化您的代码在做什么 - 但是 - 这是有代价的。一旦您的应用程序开始变得越来越大，它并不是最有效的执行代码。

无论大小，最好避免使用这些方法并直接参考工作表上的Worksheet 对象和相关Range 以查找数据并将其放在其他位置。

为了解释该问题的最佳答案，以下是避免使用这些方法的主要原因；

• 选择和选择是运行时错误的常见原因。
  • 这是因为它不依赖任何东西（代码或用户）更改工作表焦点，如果有人单击其他位置或代码中的某些内容更改工作表或选择，它可以 会导致奇怪的结果或错误。
• 如上所述，它们会减慢您的代码速度。通过一些谷歌搜索，您会发现执行的测试显示了使用这些方法和避免它们之间的时间差异。

话虽如此，这应该可以解决您的问题：

Sub CopyPaste3()

Dim row As Integer
Dim lastrow As Integer
Dim r As Integer
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim myArray As Variant
Dim Destination As Range

Set S1 = Worksheets("Sheet1")
Set S2 = Worksheets("sheet2")
rowg = 12
lastrow = S1.Range("A" & Rows.Count).End(xlUp).row


For r = 2 To lastrow
    If S1.Range("D" & r).Value = "Y" Then
        myArray = S1.Range("E" & r & ":F" & r).Value
        Set Destination = S2.Cells(rowg, 7)
        Set Destination = Destination.Resize(UBound(myArray, 2), 1)
        Destination = Application.Transpose(myArray)
        rowg = S2.Range("G" & Rows.Count).End(xlUp).row + 1
    End If
Next r
End Sub

我使用了一个数组来获取所需的 E 列到 F 值并将它们转置到您的目标范围。我使用了rowg 变量，当数据移动时，您每次迭代都会更新该变量 - 因为您已将 12 硬编码为行，所以它以前每次都会覆盖您的值，而不是移动到下一个空白行。

这里是样本 sheet1 和 sheet2 数据的片段：

表 1

表 2：

Answer 2

我会怎么做：

Sub Shelter_In_Place()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim i As Long, lr1 As Long, lr2 As Long

lr1 = ws1.Range("D" & ws1.Rows.Count).End(xlUp).row
lr2 = ws2.Range("G" & ws2.Rows.Count).End(xlUp).row

For i = 2 To lr1
    If ws1.Range("D" & i) = "Y" Then

        ws1.Range("E" & i).Resize(1, 2).Copy
        ws2.Range("G" & lr).PasteSpecial xlPasteAll, Transpose:=True
        lr = lr + 2

    End If
Next i

End Sub