初めに
マトリックス上になっているデータをデータベースに入れやすい形に直す際に使うマクロです。
イメージ
このようなデータだった場合は
以下のように直します。
マクロ
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
このコードをAlt+11でVBAを開きます。
そこから標準モジュールを選択し、このコードをコピペします。
そして直したいデータ上でAlt+8で実行します。