Loop Copy based on Criteria then Transpose - excel

Question

I have hit a brick wall with this. This code works in stages, probably not very efficiently.
Step 1 looks at the data on sheet1 if row13 contains a yes then it copies that columns row17,20,21 to sheet2 this part I have got to work fine through a loop.
Step 2 selects the data on sheet2 looking at the last column and row and then should transpose it to sheet3. This part doesn't work at all. If i could skip the sheet3 and transpose direct onto sheet2 with the loop that would be even better.
Here is a screen shot of sheet1 the blanks do have data in the final sheet but are not applicable for this so have been removed.
Here is a screen shot of sheet2 this is currently how it appears after the loop.
This is how i imagine it looks when it is transposed sheet3
Here is my code so far: -
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
I have highlighted where it has an error.
I have tried recording a macro to get the transpose part, which gave this result: -
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
So i would like help getting the selection on sheet2 which can vary to copy and transpose. If anyone has any suggestions on how to make it slicker would also be appreciate.
If you can explain what you do, this will help me learn, thank you!
Any help would be greatly appreciated.

Answer 1

Read this on how to avoid Select, which makes your code more efficient and tidier.
The immediate cause of your error was not fully qualifying ranges by adding worksheet references.
This should work.
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

Answer 2

Try,
Sub test()
Dim vDB, vResult()
Dim Ws As Worksheet, toWs As Worksheet
Dim j As Integer, n As Integer, c As Integer
Set Ws = Sheets(1)
Set toWs = Sheets(2)
With Ws
c = .Cells(13, Columns.Count).End(xlToLeft).Column
vDB = .Range("b13", .Cells(21, c))
End With
For j = 1 To UBound(vDB, 2)
If vDB(1, j) = "Yes" Then
n = n + 1
ReDim Preserve vResult(1 To 3, 1 To n)
vResult(1, n) = vDB(5, j)
vResult(2, n) = vDB(8, j)
vResult(3, n) = vDB(9, j)
End If
Next j
With toWs
.Range("a1").CurrentRegion.Clear
.Range("a1").Resize(1, 3) = Array("Name", "Lines", "Quantity")
If n Then
.Range("a2").Resize(n, 3) = WorksheetFunction.Transpose(vResult)
End If
End With
End Sub