CODEWITHSUNDEEP
excelvba
Steven Byrne
Steven Byrne

Reputation: 134

Loop Copy based on Criteria then Transpose

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. enter image description here

Here is a screen shot of sheet2 this is currently how it appears after the loop. enter image description here

This is how i imagine it looks when it is transposed sheet3

enter image description here

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.

Upvotes: 0

Views: 46

Answers (2)

Dy.Lee
Dy.Lee

Reputation: 7567

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

Upvotes: 1

SJR
SJR

Reputation: 23081

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

Upvotes: 1

Related Questions