excel vba 我需要将数据从列转置为行

我正在寻找一个 VBA 解决方案来转换类似于下图的场景中的数据。从Sheet1仅当它们左侧的任何单元格（D3，E3，...）中存在值时，才复制前三个单元格值（A3，B3，C3）Sheet2过去前 3 个单元格值 (A2、B2、C2)，以及之后的第一个单元格值 (D3)，并将标题值复制到相邻单元格中。左侧的任何其他值都会得到相同的处理并成为下一行，再次复制 (A3,B3,C3)。然后将下一个相邻单元格值（E3）连同标题值一起放入相邻单元格中。然后向下移动到下一行Sheet1其中前 3 个单元格后面有值，直到它一直循环到sheet1 以生成中的示例Sheet2.

我搜索过其他类似的解决方案，但找不到任何有效的解决方案。这是我发现的最接近的，我做了一些小的编辑，但不起作用，非常感谢任何帮助。

Sub Sample()
Dim wsThis As Worksheet
Dim wsThat As Worksheet
Dim ThisAr As Variant
Dim ThatAr As Variant
Dim Lrow As Long
Dim Col As Long
Dim i As Long
Dim k As Long

Set wsThis = Sheet1: Set wsThat = Sheet2

With wsThis
    '~~> Find Last Row in Col A
    Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    '~~> Find total value in D,E,F so that we can define output array
    Col = Application.WorksheetFunction.CountA(.Range("C2:G" & Lrow))

    '~~> Store the values from the range in an array
    ThisAr = .Range("A2:G" & Lrow).Value

    '~~> Define your new array
    ReDim ThatAr(1 To Col, 1 To 7)

    '~~> Loop through the array and store values in new array
    For i = LBound(ThisAr) To UBound(ThisAr)
        k = k + 1

        ThatAr(k, 1) = ThisAr(i, 1)
        ThatAr(k, 2) = ThisAr(i, 2)
        ThatAr(k, 3) = ThisAr(i, 3)

        '~~> Check for Color 1
        If ThisAr(i, 5) <> "" Then 'ThatAr(k, 4) = ThisAr(i, 4)
            k = k + 1
            ThatAr(k, 1) = ThisAr(i, 1)
            ThatAr(k, 2) = ThisAr(i, 2)
            ThatAr(k, 3) = ThisAr(i, 3)
            ThatAr(k, 4) = ThisAr(i, 4)
            ThatAr(k, 5) = ThisAr(i, 5)
        End If

        '~~> Check for Color 2
        If ThisAr(i, 7) <> "" Then
            k = k + 1
            ThatAr(k, 1) = ThisAr(i, 1)
            ThatAr(k, 2) = ThisAr(i, 2)
            ThatAr(k, 3) = ThisAr(i, 3)
            ThatAr(k, 6) = ThisAr(i, 6)
            ThatAr(k, 7) = ThisAr(i, 7)
        End If

        '~~> Check for Color 3
        'If ThisAr(i, 6) <> "" Then
            'k = k + 1
            'ThatAr(k, 1) = ThisAr(i, 1)
            'ThatAr(k, 2) = ThisAr(i, 2)
            'ThatAr(k, 3) = ThisAr(i, 3)
            'ThatAr(k, 4) = ThisAr(i, 6)
        'End If
    Next i
End With

'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value

'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub

使用变体数组（动态数组）既简单又快速。

Sub test()
    Dim wsThis As Worksheet, wsThat As Worksheet
    Dim vDB As Variant, vR() As Variant
    Dim r As Long, i As Long, n As Long
    Dim c As Integer, j As Integer, k As Integer

    Set wsThis = Sheet1: Set wsThat = Sheet2

    vDB = wsThis.Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For i = 2 To r
        For j = 4 To c
            If vDB(i, j) <> "" Then
                n = n + 1
                ReDim Preserve vR(1 To 5, 1 To n)
                For k = 1 To 3
                    vR(k, n) = vDB(i, k)
                Next k
                vR(4, n) = vDB(i, j)
                vR(5, n) = vDB(1, j)
            End If
        Next j
    Next i
    With wsThat
        .UsedRange.Clear
        .Range("a1").Resize(1, 3) = wsThis.Range("a1").Resize(1, 3).Value
        .Range("d1").Resize(1, 2) = Array("Value", "ID#")
        .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
    End With
End Sub