エクセルで横に並んだ複数デーブルを一つの縦に並んだテーブルに処理するマクロ

shrink_colums.vb

Sub shrink_colums()

    ' ---------- 要設定ゾーン Start ----------
    NUM_COL_SET = 2  ' ２列１セット
    HEADER_OFFSET = 1  ' ヘッダ行の行数
    FROM_SHEET_NAME = "Sheet1"  ' コピー元のシート名
    TO_SHEET_NAME = "ColumnShrinked"  ' コピー先のシート名
    ' ---------- 要設定ゾーン End ----------

    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = TO_SHEET_NAME

    Worksheets(FROM_SHEET_NAME).Activate
    num_col = Cells(HEADER_OFFSET, 1).End(xlToRight).Column

    Worksheets(FROM_SHEET_NAME).Range(Cells(HEADER_OFFSET,1), Cells(HEADER_OFFSET, NUM_COL_SET)).Copy Worksheets(TO_SHEET_NAME).Cells(HEADER_OFFSET, 1)

    current_bottom_row = HEADER_OFFSET
    Dim x As Integer
    For x = 1 To num_col Step NUM_COL_SET
        num_row = Cells(HEADER_OFFSET+1, x).End(xlDown).Row - HEADER_OFFSET

        Worksheets(FROM_SHEET_NAME).Range(Cells(HEADER_OFFSET+1, x), Cells(HEADER_OFFSET+num_row, x+NUM_COL_SET-1)).Copy Worksheets(TO_SHEET_NAME).Cells(current_bottom_row+1, 1)
        current_bottom_row = current_bottom_row + num_row
    Next x

    MsgBox "Finished!!! Result Sheet Name is " &  TO_SHEET_NAME
    Worksheets(TO_SHEET_NAME).Activate
End Sub

元データ

このコードで整形されてできるデータ