L oop Копировать на основе критериев, затем транспонировать

Question

Я ударил этим кирпичную стену. Этот код работает поэтапно, вероятно, не очень эффективно.

Шаг 1 просматривает данные на sheet1, если row13 содержит yes, то он копирует эти columns row17,20,21 в sheet2 с этой частью я должен нормально работать через al oop.

Шаг 2 выбирает данные на sheet2, глядя на последние column и row, а затем должен транспонировать их в sheet3. Эта часть вообще не работает. Если бы я мог пропустить sheet3 и перенести прямо на sheet2 с l oop, это было бы еще лучше.

Вот снимок экрана sheet1. Пробелы содержат данные на последнем листе, но не применимы для этого, поэтому были удалены.

Вот снимок экрана sheet2, так он выглядит сейчас после l oop.

Вот как я себе это представляю при транспонировании 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, который может меняться для копирования и транспонирования. Если у кого-то есть предложения о том, как сделать его более привлекательным, также буду признателен.

Если вы можете объяснить, что вы делаете, это поможет мне научиться, спасибо!

Любая помощь будет принята с благодарностью.

Answer 1

Попробуйте,

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

Answer 2

Прочтите этот о том, как избежать Select, что делает ваш код более эффективным и аккуратным.

Непосредственной причиной вашей ошибки было неполное определение диапазонов путем добавления ссылок на листы.

Это должно работать.

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