'マトリックス表から一覧表を作成するマクロ

'例えば以下の表から・・・

'     A      B      C
' 1        Item1  Item2
' 2  Key1    100    200
' 3  Key2    200    300
' 4  Key3    300    400

'次のような一覧表を作成します。

'     A      B     C
' 1
' 2  Key1  Item1  100
' 3  Key1  Item2  200
' 4  Key2  Item1  200
' 5  Key2  Item2  300
' 6  Key3  Item1  300
' 7  Key3  Item2  400

'対象セル範囲を選択して、MyTableToListマクロを実行してください。
'複数セル範囲には対応していません。

Option Explicit

Sub MyTableToList()
    Const myTitle = "マトリックス表から一覧表を作成"
    Dim range1 As Range, range2 As Range
    Dim rowCount As Long, colCount As Long
    Dim i As Long, j As Long, k As Long

    On Error GoTo err_1

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択して実行してください。", _
            vbExclamation, myTitle
        Exit Sub
    End If

    Selection.Areas(1).Select
    If Selection.Cells.Count = 1 Then Selection.CurrentRegion.Select

    Set range1 = InputBoxRange( _
        prompt:="範囲の先頭行と先頭列を見出しとして一覧表を作成します。" _
        & Chr$(10) & "対象のセル範囲を入力してください。", _
        title:=myTitle, default:=Selection.Address(True, True))
    If range1 Is Nothing Then Exit Sub
    Set range1 = range1.Areas(1)
    range1.Select

    rowCount = range1.Rows.Count
    colCount = range1.Columns.Count

    If rowCount <= 1 Or colCount <= 1 Then
        MsgBox "データがありません。", vbExclamation, myTitle
        Exit Sub
    End If

    Select Case MsgBox("結果出力シートをアクティブブックに追加しますか？", _
            vbYesNoCancel Or vbExclamation, myTitle)
        Case vbYes
            Set range2 = Worksheets.Add.Cells(1, 1)
        Case vbNo
            Set range2 = Workbooks.Add(xlWorksheet).Worksheets(1).Cells(1, 1)
        Case Else
            Exit Sub
    End Select

    Application.ScreenUpdating = False

    range2.Value = range1.Cells(1, 1).Value

    k = 2
    For i = 2 To rowCount
        For j = 2 To colCount
            range2.Cells(k, 1).Value = range1.Cells(i, 1).Value
            range2.Cells(k, 2).Value = range1.Cells(1, j).Value
            range2.Cells(k, 3).Value = range1.Cells(i, j).Value
            k = k + 1
        Next
    Next

    Exit Sub
err_1:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, myTitle
End Sub

Function InputBoxRange(prompt As String, title As String, _
        default As String) As Range
    On Error Resume Next
    Set InputBoxRange = Application.InputBox( _
        prompt:=prompt, title:=title, default:=default, Type:=8)
End Function