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

我会怎么做：

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

Answer 2

详细说明Avoid using Select。

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

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

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

Select and Selection are a common cause for run-time errors.

This is because it relies on nothing (either code or the user) changing the sheets focus, If someone clicks somewhere else or something in your code changes the sheet or selection, it ~~can~~ will cause funky results or an error.

As mentioned above, they slow your code down. With a bit of googling you'll find tests performed showing the differences in time between using these methods and avoiding them.

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

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 数据的片段：

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

VBA Copy Paste into new worksheet, If statement and transpose

excel

vba

transpose

工作表 1

工作表 2：