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

【问题标题】：How to convert columns to rows in excel vba based on column condition如何根据列条件将列转换为excel vba中的行
【发布时间】：2016-09-09 15:01:23
【问题描述】：

输入：

1 2 3
b 1 2 3
c 1 2 3

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

提前致谢。

【问题讨论】：

看起来您正在将行转换为列。我会创建一个数组并使用WorksheetFunction.Transpose 来翻转它的尺寸，但您也可以使用Range().Copy 和Range().PasteSpecial Transpose:=True。如果您在发布代码时遇到问题，我很乐意提供帮助。

标签： vba excel

【解决方案1】：

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

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

【讨论】：

感谢您的快速回复，但在这里，我通过在拆分数据之间添加标题来获取单独的数据集。但我的要求是通过在顶行上只有一个标题来获得合并数据，如下所示a b c 1 1 1 2 2 2 3 3 3 1 12 13 16 15 14 17 16 17
感谢您的快速回复，但在这里，我通过在拆分数据之间添加标题来获取单独的数据集。但我的要求是通过在顶行上只有一个标题来获得合并数据，如下所示a b c 1 1 1 2 2 2 3 3 3 1 12 13 16 15 14 17 16 17
@TSurendra 我的新答案符合您的要求。

【解决方案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

【讨论】：