vba - 複数列テーブルを単一列テーブルに変換するための 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

出力：