Как go перейти к следующей строке (таблице результатов) в этом коде? вертикальное в горизонтальное транспонирование

Question

 Sub Test2()

    Dim i&, j&, vIn, vOut

    With ThisWorkbook

        vIn = .Worksheets(1).Range("a1").CurrentRegion.Value2

        ReDim vOut(1 To UBound(vIn, 2), 1 To UBound(vIn, 1))

        For i = 1 To UBound(vIn, 1)
            For j = 1 To UBound(vIn, 2)
                vOut(j, i) = vIn(i, j)
            Next
        Next

        .Worksheets(2).Range("a1").Resize(UBound(vOut, 1), UBound(vOut, 2)) = vOut

    End With
End Sub

Проблема - Невозможно go перейти к следующей строке, если я запускаю программу для следующего набора данных для транспонирования.

Answer 1

Если это только Range(B2:B5") или подобное каждый раз, тогда вам не нужно использовать массив для этого. Это перебор для этой ситуации. Вы можете использовать Copy | PasteSpecial - Transpose для достижения того, что вы хотите. Также избегайте использования Worksheets(1), Worksheets(2). Используйте их кодовые имена или имена листов. Использование номера индекса может дать вам нежелательные результаты, если положение листа сместится.

Это то, что вы пытаетесь? ( Не проверено )

Option Explicit

Sub Sample()
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim lRow As Long

    '~~> Change the sheet names as applicable
    Set wsIn = ThisWorkbook.Sheets("Sheet1")
    Set wsOut = ThisWorkbook.Sheets("Sheet2")

    With wsOut
        '~~> Find next available row
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1

        '~~> Copy relevant range
        wsIn.Range("B2:B5").Copy

        '~~> Write to relevant area
        .Range("A" & lRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                                        SkipBlanks:=False, Transpose:=True
    End With
    Application.CutCopyMode = False
End Sub

Answer 2

Проблема в том, что вы всегда пишете в Range("a1") при использовании этой строки

.Worksheets(2).Range("a1").Resize(UBound(vOut, 1), UBound(vOut, 2)) = vOut

Вместо этого сначала найдите следующую свободную строку

Dim NextFreeRow As Long
NextFreeRow = .Worksheets(2).Cells(.Worksheets(2).Rows.Count, "A").End(xlUp).Row + 1

, а затем используйте эту строку в качестве начальной point

.Worksheets(2).Cells(NextFreeRow, "A").Resize(UBound(vOut, 1), UBound(vOut, 2)) = vOut

---

На самом деле вы можете захотеть взглянуть на метод WorksheetFunction.Transpose . Это было бы намного проще перенести данные.