如何根据列条件将列转换为excel vba中的行

Question

输入：

a 1 2 3
b 1 2 3
c 1 2 3

a 1 16 17
b 12 15 16
c 13 14 17

我的excel中有这种数据。我希望在vba脚本的帮助下看到我所需的输出如下所示。

必需的操作：

a b c
1 1 1
2 2 2
3 3 3
1 12 13
16 15 14
17 16 17

提前致谢。

Answer 1

在这里，我利用For Each逐列迭代2D数组列的事实，并逐行填充范围以转置数据。

Sub JustPlayingAround()
    Dim arArea, v
    Dim rArea As Range, rSource As Range, rDestination As Range
    Dim x As Long
    Set rSource = Range("A1", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    Set rDestination = Range("H1").Resize(1, 3)

    For Each rArea In rSource.Areas
        For Each v In rArea.Value
            x = x + 1
            rDestination(x) = v
        Next
    Next
End Sub

Answer 2

Sub TransposeData()
    Const FirstHeader As String = "a"
    Dim arCurrent, arAll
    Dim lastRow As Long, x As Long, xAll As Long, y As Long
    Dim firstAddress As String
    Dim c As Range

    With Worksheets("Sheet1").Columns(1)
        lastRow = .Rows(Rows.Count).End(xlUp).Row
        Set c = .Find(FirstHeader, After:=.Rows(Rows.Count), LookIn:=xlValues)
        If Not c Is Nothing Then
            ReDim arAll(lastRow, c.CurrentRegion.Rows.Count - 1)
            firstAddress = c.Address
            Do
                arCurrent = c.CurrentRegion.Value2
                If IsArray(arCurrent) Then
                    arCurrent = Application.Transpose(arCurrent)

                    For x = IIf(x = 0, 1, 2) To UBound(arCurrent, 1)
                        For y = 1 To UBound(arCurrent, 2)
                            arAll(xAll, y - 1) = arCurrent(x, y)
                        Next
                        xAll = xAll + 1
                    Next
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
    Worksheets.Add
    Range("A1").Resize(xAll + 1, UBound(arAll, 2) + 1) = arAll

End Sub