Транспонировать динамический диапазон данных c из вертикального в горизонтальный формат

Question

Это данные, предоставленные мне, вы можете увидеть столбцы B и C похожи во всех аспектах, кроме данных экспорта элементов:

Это данные, которые транспонируются в горизонтальном направлении без кода VBA:

Проблема возникает только тогда, когда я пытаюсь сделать это с помощью кода VBA, я не получаю оставшиеся данные как есть. оно приходит в беспорядке.

  Sub test2()
    Dim Ws As Worksheet
    Dim toWs As Worksheet
    Dim vDB, vR()
    Dim rngDB As Range
    Dim i As Long, j As Long, n As Long
    Dim r As Long, c As Long, k As Long

    Set Ws = Sheets(1)
    Set toWs = Sheets(2)

    Set rngDB = Ws.Range("a1").CurrentRegion
    vDB = rngDB

    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For j = 2 To c
        n = n + 1
        'ReDim Preserve vR(1 To 4, 1 To n)
        ReDim Preserve vR(1 To 5, 1 To n)
        vR(1, n) = vDB(1, j)
        vR(2, n) = vDB(2, j)
        vR(3, n) = vDB(3, j)
        vR(4, n) = vDB(4, j)
        vR(5, n) = vDB(r, j) 'added insurance
        'For i = 5 To r
        For i = 5 To r - 1
            If vDB(i, j) <> "" Then
                n = n + 1
                ReDim Preserve vR(1 To 5, 1 To n)
                vR(4, n) = vDB(i, j)
            End If
        Next i
    Next j

    With toWs
        k = .UsedRange.Rows.Count + 1
        '.Range("a" & k).Resize(n, 4) = WorksheetFunction.Transpose(vR)
        .Range("a" & k).Resize(n, 5) = WorksheetFunction.Transpose(vR)
    End With

End Sub

Answer 1

Попробуйте это:

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

Более универсальный c, многоразовый и функциональный способ сделать это будет выглядеть так ...

Sub Test3()

    Dim vIn

    With ThisWorkbook        
        vIn = .Worksheets(1).[a1].CurrentRegion.Value2
        .Worksheets(2).[a1].Resize(UBound(vIn, 2), UBound(vIn, 1)) = MyTranspose(vIn)            
    End With

End Sub

Function MyTranspose(vIn)

    Dim i&, j&, vOut

    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    
    MyTranspose = vOut

End Function

Answer 2

Транспонировать данные

tltr; и я не следовал предыдущему обсуждению ... но почему бы просто не применить Application.Transpose() ко всему набору данных вместо выполнения внутренних и внешних циклов?

Option Explicit                                               ' declaration head of code module

Sub TransposeData()
    '[1]get data and assign them to variant 1-based 2-dim array
        Dim v ' As Variant
        v = Sheet1.Range("A1").CurrentRegion.Value2            ' << change to your source worksheet's CodeName

    '[2]transpose data and write to target sheet - e.g. Code(Name) Sheet2  
        Sheet2.Range("A1").Resize(UBound(v, 2), UBound(v, 1)) = Application.Transpose(v)

End Sub