'レコード分割とマージのマクロサンプル

'Sheet1の表を、Sheet2のように分割し、さらにSheet3のようにマージします。
'各シートを用意し、Test1マクロを実行してください。Sheet1にはデータが必要です。

'Sheet1
'     |   A    |   B    |   C   |   D   |
'  ---+--------+--------+-------+-------+
'   1 | Field1 | Field2 |       |       |
'   2 | Key1   | Data1  | Data2 | Data3 |
'   3 | Key2   | Data2  | Data3 |       |
'   4 | Key3   | Data4  |       |       |

'Sheet2
'     |   A    |   B    |
'  ---+--------+--------+
'   1 | Field1 | Field2 |
'   2 | Key1   | Data1  |
'   3 | Key1   | Data2  |
'   4 | Key1   | Data3  |
'   5 | Key2   | Data2  |
'   6 | Key2   | Data3  |
'   7 | Key3   | Data4  |

'Sheet3
'     |   A    |   B    |  C   |
'  ---+--------+--------+------+
'   1 | Field2 | Field1 |      |
'   2 | Data1  | Key1   |      |
'   3 | Data2  | Key1   | Key2 |
'   4 | Data3  | Key1   | Key2 |
'   5 | Data4  | Key3   |      |


Option Explicit

'レコード分割マクロ
Sub MyRecordDivide(range1 As Range, range2 As Range, _
        keyColumn As Integer, keyFieldCount As Integer, _
        dataColumn As Integer, dataFieldCount As Integer, _
        dataRecordCount As Integer)
    Dim cnt As Long
    Dim i As Long, j As Long, k As Long
    Dim r As Range

    '出力カウンタの初期化
    cnt = 0

    '行単位に処理
    For Each r In range1.Rows

        '各データレコードに対して処理
        For i = 0 To dataRecordCount - 1

            'データレコードの先頭列位置を取得
            k = dataColumn + dataFieldCount * i

            'データレコードの先頭がEmptyの場合は出力しない
            If Not IsEmpty(r.Cells(1, k).Value) Then

                '出力カウンタの更新
                cnt = cnt + 1

                'キーフィールドの出力
                For j = 0 To keyFieldCount - 1
                    range2.Cells(cnt, j + 1).Value _
                        = r.Cells(1, keyColumn + j).Value
                Next

                'データフィールドの出力
                For j = 0 To dataFieldCount - 1
                    range2.Cells(cnt, keyFieldCount + j + 1).Value _
                        = r.Cells(1, k + j).Value
                Next
            End If
        Next
    Next
End Sub

'レコードマージマクロ
Sub MyRecordMerge(range1 As Range, range2 As Range, _
        keyColumn As Integer, keyFieldCount As Integer, _
        dataColumn As Integer, dataFieldCount As Integer)
    Dim cnt As Long
    Dim i As Integer, columnCount As Long
    Dim r As Range
    Dim currentKey() As Variant
    Dim ifBreak As Boolean

    ReDim currentKey(0 To keyFieldCount - 1)

    '出力レコード数の初期化
    cnt = 0

    '行単位に処理
    For Each r In range1.Rows

        'キーブレイクのチェック
        ifBreak = False
        For i = 0 To keyFieldCount - 1
            If currentKey(i) <> r.Cells(1, keyColumn + i) Then
                ifBreak = True
                Exit For
            End If
        Next

        If ifBreak Then

            'ブレイク時処理

            '出力カウンタの更新
            cnt = cnt + 1

            'キーフィールドの出力
            For i = 0 To keyFieldCount - 1
                range2.Cells(cnt, i + 1).Value _
                    = r.Cells(1, keyColumn + i).Value
            Next

            'データフィールドの出力
            For i = 0 To dataFieldCount - 1
                range2.Cells(cnt, keyFieldCount + i + 1).Value _
                    = r.Cells(1, dataColumn + i).Value
            Next

            '列カウンタの初期化
            columnCount = keyFieldCount + dataFieldCount

            '現在のキーの更新
            For i = 0 To keyFieldCount - 1
                currentKey(i) = r.Cells(1, keyColumn + i)
            Next
        Else

            'データフィールドの出力
            For i = 0 To dataFieldCount - 1
                range2.Cells(cnt, columnCount + i + 1).Value _
                    = r.Cells(1, dataColumn + i).Value
            Next

            '列カウンタの更新
            columnCount = columnCount + dataFieldCount
        End If
    Next
End Sub


'テストマクロ

'なお、MyRecordDivide()とMyRecordMerge()は項目見出しの処理は
'行いません。

Sub Test1()
    Dim r1 As Range, r2 As Range, r3 As Range
    Set r1 = Sheets("Sheet1").Cells(1, 1)
    Set r2 = Sheets("Sheet2").Cells(2, 1)
    Set r3 = Sheets("Sheet3").Cells(2, 1)

    r2.Worksheet.Cells.Clear
    r2.Cells(0, 1).Value = r1.Cells(1, 1).Value
    r2.Cells(0, 2).Value = r1.Cells(1, 2).Value
    r3.Worksheet.Cells.Clear
    r3.Cells(0, 1).Value = r1.Cells(1, 2).Value
    r3.Cells(0, 2).Value = r1.Cells(1, 1).Value

    With r1.CurrentRegion
        If .Rows.Count > 1 And .Columns.Count > 1 Then
            MyRecordDivide .Resize(.Rows.Count - 1).Offset(1), _
                r2, 1, 1, 2, 1, .Columns.Count - 1
        End If
    End With

    r2.CurrentRegion.SortSpecial SortMethod:=xlCodePage, _
        key1:=r2.Cells(2, 2), Order1:=xlAscending, _
        Key2:=r2.Cells(2, 1), Order2:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom

    With r2.CurrentRegion
        If .Rows.Count > 1 And .Columns.Count > 1 Then
            MyRecordMerge .Resize(.Rows.Count - 1).Offset(1), _
                r3, 2, 1, 1, 1
        End If
    End With

End Sub