我需要Excel VBA代码将多列表转换为单列表

Question

输入：Excel表

Data    4/1/2012    4/2/2012    4/3/2012    4/4/2012    4/5/2012
V        10 20  30  40  50
H   5   10  15  20  25
S   6   12  18  24  30
R   8   16  24  32  40
A   9   18  27  36  45

Output : Excel Table
V        4/1/2012    10
V        4/2/2012    20
V        4/3/2012    30
V        4/4/2012    40
V        4/5/2012    50
H        4/1/2012    5
H        4/2/2012    10
H        4/3/2012    15
H        4/4/2012    20
H        4/5/2012    25
.
.
.
A        4/1/2012    9
A        4/2/2012    18
A        4/3/2012    27
A        4/4/2012    36
A        4/5/2012    45

Answer 1

以下是使用Arrays的解决方案。在代码中，有几个静态范围。因此，您需要相应地设置工作表名称，起始单元名称。

Option Explicit

Sub colsToRows()
Dim ws1 As Worksheet
Dim a As Long, lr As Long, lc As Long
Dim va As Variant, vd As Variant
Dim LastRow As Long, LastCol As Long

        '-- set e.g. sheet name Sheet1, starting column = B, dates starting cell = C2
        Set ws1 = Sheets("Sheet1")
        LastRow = ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row
        LastCol = ws1.Cells(Range("C2").Row, ws1.Columns.Count).End(xlToLeft).Column - 1

        '--put dates into this array as it repeats for each item
        vd = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Resize(1, LastCol - 1)))

        '-- titles
        ws1.Range("B2").Offset(LastRow + 1) = "Item"
        ws1.Range("C2").Offset(LastRow + 1) = "Dates"
        ws1.Range("D2").Offset(LastRow + 1) = "Data"

        '--2 is deducted as the main range is starting from B3. So B3-B1 = 2
        For a = 1 To LastRow - 2
           '--to get next last row
            lr = Cells(Rows.Count, "B").End(xlUp).Row

            '--items
            va = Array(ws1.Range("B2").Offset(a).Value)
            ws1.Range("B1").Offset(lr).Resize(LastCol - 1) = Application.Transpose(va)

            '--dates
            ws1.Range("C1").Offset(lr).Resize(UBound(vd)) = Application.Transpose(vd)

            '--data
            va = WorksheetFunction.Transpose(WorksheetFunction.Transpose(ws1.Range("C2").Offset(a).Resize(1, LastCol - 1)))
            ws1.Range("D1").Offset(lr).Resize(UBound(va)) = Application.Transpose(va)
        Next a

End Sub

<强>输出：