Loop Copy based on Criteria then Transpose

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.

score 1 · Accepted Answer · answered May 26 '20 at 15:42

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

answered May 26 '20 at 15:42

SJR

22,986
6
18
26

Thank you very much @SJR this is brilliant and much shorter than mine. Also appreciate the reference to the other page in avoiding select, very interesting. I have saved it for future reference. Thank you. – Steven Byrne May 27 '20 at 04:59
what does the `(2)` represent after the `.End(xlUp)` I have never seen that before (i haven't been doing this, this long though). Thank you. – Steven Byrne May 27 '20 at 06:38
Aah sussed it it adds rows onto the row count. Been trying to do this another way with no luck, didn't know of this way. Thank you. – Steven Byrne May 27 '20 at 06:56
1

Glad it worked. Yes it's a shorthand equivalent to `Offset(1,0)`. So eg `range("A1")(2)` or `range("A1")(2,1)` is the same as `range("A2")`. – SJR May 27 '20 at 13:59

score 1 · Answer 2 · answered May 26 '20 at 16:02

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

Thank you @Dy.Lee this also worked. :-) there are a few things in here i have not seen before so will look into them `UBound`. Liked the use of the `array`, never seen that done before but makes sense and i will use it. Thank you for your help. — Steven Byrne, May 27 '20 at 05:07
@StevenByrne, Yes, this is 2 dimension array. So it use `Ubound`. — Dy.Lee, May 27 '20 at 14:04

Loop Copy based on Criteria then Transpose

2 Answers2