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

Question

我正在寻找一种 VBA 解决方案来转换类似于下图的场景中的数据。 从Sheet1复制前三个单元格值 (A3,B3,C3) 仅当Sheet2前三个单元格值 (A2,B2,C2) 左侧的任何单元格 (D3,E3,...) 中有值时)，然后是带有值 (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

Answer 1

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

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

Answer 2

抱歉，我不知道为什么我无法打开您附加的图片。 但你可能想试试这个代码：

Change this line:
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
To
wsThat.Range("A2").Resize(4, Col).Value = WorksheetFunction.Transpose(ThatAr)

希望这有帮助