Excel 基于条件的循环复制，然后转置

我用这个撞到了砖墙。这段代码分阶段工作，可能效率不高

步骤1查看

sheet1

上的数据，如果

row13

包含

yes

，那么它会将

列
row17,20,21
复制到
sheet2
这一部分我必须通过循环正常工作

步骤2选择查看最后一列
和行
的
表2
上的数据，然后将其转置到
表3
。这部分根本不起作用。如果我能跳过
sheet3
，直接将循环转换到
sheet2
，那就更好了

这是
sheet1
的屏幕截图。最后一张表格中有空白数据，但不适用于此，因此已删除。

这是
sheet2
的屏幕截图，这是循环后的当前显示方式。

这就是我想象它被转置时的样子
sheet3


以下是我目前的代码：-

Sub Collect()

ThisWorkbook.Worksheets("Sheet2").Range("B1:U9999").ClearContents
Dim i As Integer

For i = 2 To 21
    If Cells(13, i) = "Yes" Then

    ThisWorkbook.Worksheets("Sheet1").Select
    ThisWorkbook.Worksheets("Sheet1").Cells(17, i).Copy 'Name
    ThisWorkbook.Worksheets("Sheet2").Select
    ThisWorkbook.Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 'Paste Name
    ThisWorkbook.Worksheets("Sheet1").Select
    ThisWorkbook.Worksheets("Sheet1").Cells(20, i).Copy 'Lines
    ThisWorkbook.Worksheets("Sheet2").Select
    ThisWorkbook.Worksheets("Sheet2").Cells(2, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 'Paste Name
    ThisWorkbook.Worksheets("Sheet1").Select
    ThisWorkbook.Worksheets("Sheet1").Cells(21, i).Copy 'Quantity
    ThisWorkbook.Worksheets("Sheet2").Select
    ThisWorkbook.Worksheets("Sheet2").Cells(3, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 'Paste Quantity
    ThisWorkbook.Worksheets("Sheet1").Select

    End If
Next i

    ThisWorkbook.Worksheets("Sheet3").Range("A1:U9999").ClearContents

    ThisWorkbook.Worksheets("Sheet2").Select

    Dim lRow As Long, lCol As Long
    lRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
    lCol = Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column

    Worksheets("Sheet2").Range(Cells(lRow, 1), Cells(lRow, lCol)).Select 'it errors here

    Selection.Copy
    ThisWorkbook.Worksheets("Sheet3").Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

我已经强调了它有错误的地方

我尝试录制宏以获得转置部分，结果如下：-

Sub Transpose()
'
' Transpose Macro

    Range("A1:F3").Select
    Selection.Copy
    Sheets("Sheet3").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

因此，我想帮助您获得
sheet2
上的选项，这些选项可以根据复制和转置的不同而有所不同。如果有人对如何使它更光滑有任何建议，也将不胜感激

如果你能解释你做了什么，这将帮助我学习，谢谢

任何帮助都将不胜感激
 阅读如何避免
选择
，这会使您的代码更高效、更整洁

错误的直接原因是没有通过添加工作表引用完全限定范围

这应该行得通

Sub x()

Dim c As Long

With Worksheets("Sheet1")
    For c = 1 To .Cells(13, Columns.Count).End(xlToLeft).Column
        If .Cells(13, c).Value = "Yes" Then
            Union(.Cells(17, c), .Cells(20, c), .Cells(21, c)).Copy
            Sheet2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True
        End If
    Next c
End With

End Sub

阅读如何避免
选择
，这会使您的代码更高效、更整洁

错误的直接原因是没有通过添加工作表引用完全限定范围

这应该行得通

Sub x()

Dim c As Long

With Worksheets("Sheet1")
    For c = 1 To .Cells(13, Columns.Count).End(xlToLeft).Column
        If .Cells(13, c).Value = "Yes" Then
            Union(.Cells(17, c), .Cells(20, c), .Cells(21, c)).Copy
            Sheet2.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True
        End If
    Next c
End With

End Sub

试试看

试试看

非常感谢@SJR这太棒了，比我的短多了。同时也感谢在避免选择中引用其他页面，非常有趣。我把它保存起来以备将来参考。谢谢。在
.End（xlUp）
之后，
（2）
代表了什么？我以前从未见过这一点（虽然我很久没有这样做过）。谢谢。啊，用它把行数加到行数上。我一直在尝试另一种方法，但运气不佳，我不知道这种方法。谢谢，很高兴它成功了。是的，它是相当于偏移量（1,0）
的速记。因此，例如
range（“A1”）（2）
或
range（“A1”）（2,1）
与
range（“A2”）
是相同的。非常感谢@SJR，这是非常出色的，比我的短得多。同时也感谢在避免选择中引用其他页面，非常有趣。我把它保存起来以备将来参考。谢谢。在
.End（xlUp）
之后，
（2）
代表了什么？我以前从未见过这一点（虽然我很久没有这样做过）。谢谢。啊，用它把行数加到行数上。我一直在尝试另一种方法，但运气不佳，我不知道这种方法。谢谢，很高兴它成功了。是的，它是相当于偏移量（1,0）
的速记。因此，例如
range（“A1”）（2）
或
range（“A1”）（2,1）
与
range（“A2”）
是相同的。谢谢@Dy.Lee这同样有效。：-）这里有一些我以前没有见过的东西，所以我将研究它们
UBound
。喜欢使用
数组
，以前从未见过这样做，但很有意义，我会使用它。谢谢您的帮助。@StevenByrne，是的，这是二维数组。所以它使用了
Ubound
。谢谢@Dy.Lee这也起作用了。：-）这里有一些我以前没有见过的东西，所以我将研究它们
UBound
。喜欢使用
数组
，以前从未见过这样做，但很有意义，我会使用它。谢谢您的帮助。@StevenByrne，是的，这是二维数组。因此它使用
Ubound
。