Excel VBA Functionプロシージャを使いこなす。スキルを飛躍的に向上させる効率的な事務処理テクニック！

2023年5月3日

Excel VBA Functionプロシージャを使いこなす。スキルを飛躍的に向上させる効率的な事務処理テクニック！

●はじめに

今回説明するのは、Excel VBAを使用する際、効率的なプログラムを作成するためにFunctionプロシージャの説明をいたします。Functionプロシージャを使いこなすための基本知識やテクニックを順番に解説していきます。まずは、Functionプロシージャとは何か、そのメリットと、Functionプロシージャを事務処理で利用する方法について説明します。Excel VBA Functionプロシージャは、ユーザー定義の関数を作成し、ExcelのワークシートやVBA内で繰り返し利用することができます。

１・Functionプロシージャとは
Functionプロシージャは、特定の処理を実行し、その結果を戻り値として返すExcel VBAのプログラムです。Functionプロシージャは、引数を受け取り、それらをもとに計算や処理を行い、結果を戻り値として返すことができます。これにより、同じ処理を何度も行う場合や、複雑な計算を実行する場合に、コードを簡潔にし、再利用可能な形で記述できます。また、オリジナルの関数として利用する事ができます。

２・ Functionプロシージャのメリット
Functionプロシージャには以下のようなメリットがあります。
２－１．再利用性：Functionプロシージャは、一度定義すれば、プロジェクト内のどこからでも呼び出すことができます。これにより、同じ処理を繰り返し実行する際に、コードの重複を防ぎ、効率的なプログラムを作成できます。
２－２:保守性：Functionプロシージャは、処理を分割して記述することができるため、コードの可読性が向上します。また、修正や機能追加が必要な場合に、一箇所の変更で影響範囲を把握しやすくなります。
２－３:柔軟性：Functionプロシージャは、引数と戻り値を使って、さまざまなデータを処理できます。これにより、一度定義したFunctionプロシージャを、異なるデータや状況に応じて再利用することができます。

●【Function ステートメントについては、下記を参照して下さい】（Microsoft社　様）】

https://learn.microsoft.com/ja-jp/office/vba/language/concepts/getting-started/writing-a-function-procedure?source=recommendations

●書式の説明

●　Functionプロシージャを利用するには、下記の通りに設定を行います。

【構文説明】Functionプロシージャの構文は以下の通りです。
Function 関数名(引数1 As 型1, 引数2 As 型2, …) As 戻り値の型
‘ コードの記述
End Function

引数の詳細引数は、関数に渡す値で、関数の動作に影響を与えます。引数は0個以上を設定することができ、それぞれの引数にはデータ型が指定されます。戻り値の型は、関数が返す値のデータ型を指定します。

【使用例】『関数として利用する場合』
　このVBAコードは、指定された範囲（rng）内のセルの数値の合計を計算するFunctionプロシージャ（SumArray）です。この関数は、Rangeオブジェクトを引数として受け取り、その範囲内のセルの値の合計をDouble型の値として返します。下記のコードでは、ユーザー定義による関数を作成する説明を致します。下図の通りにFunctionプロシージャを使って「SumArray関数」を作成します。

【自作の関数（SumArray関数）を利用する場合】（手順）
①　まず、VBAプロジェクトにSumArray関数を含むモジュールを追加します。エディタで新しいモジュールを作成し、上記のSumArray関数のコードをそのモジュールにコピー＆ペーストしてください。
②　SumArray関数を呼び出すSubプロシージャを作成します。このSubプロシージャ内で、処理対象の範囲を指定し、SumArray関数を呼び出すことで、指定された範囲内のセルの値の合計を取得できます。
③　必要に応じて、SumArray関数の戻り値を使用して、さまざまな処理を行います。例えば、結果をメッセージボックスで表示する、別のセルに記録する、他の計算に使用するなど、目的に応じた処理を実装してください。
④　エラー処理を実装します。範囲指定やセルの値が数値でない場合など、エラーが発生する可能性がある箇所に対して、適切なエラー処理を実装してください。これにより、予期せぬ問題が発生した場合でも、適切な対処ができます。
⑤　実装が完了したら、作成したSubプロシージャを実行して、SumArray関数が正しく動作することを確認してください。問題がある場合は、コードを修正して再度実行してください。
⑥　これらの手順に従って、上記のSumArray関数を利用することができます。適切な範囲を指定し、関数の戻り値を使用して、必要な処理を実装してください。

【プログラムの流れ】
①　変数iとsumを宣言する。
②　rng.Cells.Countを取得し、Forループの上限値として設定する。
③　Forループを開始し、iを1から上限値まで1ずつ増やしていく。
④　rng.Cells(i).Valueを取得し、sumに加算する。
⑤　Forループが終了したら、sumの値を関数の戻り値として返す。

【プログラム内容（コード）】

’
’
Function SumArray(ByVal rng As Range) As Double
    ' 宣言：ループカウンタ用の変数
    Dim i As Long
    
    ' 宣言：合計値を格納するための変数
    Dim sum As Double
    
    ' ループ：rng内のすべてのセルに対して処理を実行
    For i = 1 To rng.Cells.Count
        ' 演算：現在のセルの値をsum変数に加算
        sum = sum + rng.Cells(i).Value
    ' 次のセルへ移動
    Next i
    
    ' 関数の戻り値：sum変数の値をSumArray関数の結果として返す
    SumArray = sum
End Function
’
’

’

Function SumArray(ByVal rng As Range) As Double

' 宣言：ループカウンタ用の変数

Dim i As Long

' 宣言：合計値を格納するための変数

Dim sum As Double

' ループ：rng内のすべてのセルに対して処理を実行

For i = 1 To rng.Cells.Count

' 演算：現在のセルの値をsum変数に加算

sum = sum + rng.Cells(i).Value

' 次のセルへ移動

Next i

' 関数の戻り値：sum変数の値をSumArray関数の結果として返す

SumArray = sum

End Function

’

【注意点】

①　引数の範囲（rng）が正しく設定されていることを確認してください。指定された範囲が存在しない場合や、範囲が適切でない場合は、エラーが発生する可能性があります。
②　引数の範囲（rng）内のセルが数値であることを確認してください。セルが数値でない場合（例：文字列、エラー値、空白セルなど）、コードの実行中にエラーが発生する可能性があります。
③　大きな範囲を指定すると、処理速度が遅くなる可能性があります。特に、範囲内のセルが多い場合や計算が複雑な場合は、パフォーマンスに影響が出ることがあります。適切な範囲を指定し、必要に応じて処理を最適化することが重要です。
④　この関数は単独では実行できません。他のSubプロシージャから呼び出されることを前提としています。適切なSubプロシージャを作成し、その中でこの関数を呼び出して使用してください。
⑤　戻り値がDouble型であるため、範囲内のセルの合計がDouble型の制約を超える場合、オーバーフローエラーが発生する可能性があります。適切な範囲を指定し、エラー処理を実装することが重要です。

Excel VBA Functionプロシージャを使いこなす。最大値と最小値を取得する自作関数を作成する。

●プログラム説明　(サンプル①)

下記のサンプルプログラムは、指定された範囲（rng）内の最小値と最大値を取得するためのFunctionプロシージャ（GetMinMax）と、そのFunctionプロシージャを呼び出し、結果を表示するSubプロシージャ（ShowMinMax）で構成されています。

【ワークシート上でGetMinMax関数（自作関数）として利用する場合】

GetMinMax関数は、範囲（rng）を引数として受け取り、オプションの引数getMin（デフォルトでTrue）を使用して、最小値または最大値を求めます。getMinがTrueの場合、最小値を返し、Falseの場合、最大値を返します。

【プログラムの流れ】
①　GetMinMax関数は、範囲（rng）を引数として受け取る
②　オプションの引数getMin（デフォルトでTrue）を使用して、最小値または最大値を求めます。
③　getMinがTrueの場合、最小値を返し、Falseの場合、最大値を返します。

【プログラム実行条件・注意事項】
①　範囲の指定: 引数として渡す範囲（rng）は、適切な範囲を指定することが重要です。範囲が不適切な場合（例：存在しないセルを指定する、文字列を指定するなど）、エラーが発生する可能性があります。
②　引数のデフォルト値: GetMinMax関数では、オプションの引数getMinにデフォルト値（True）が設定されています。関数を呼び出す際に、この引数を指定しないと、デフォルトで最小値が返されます。最大値を求める場合は、引数に明示的にFalseを指定する必要があります。
③　セルの値の型: このコードは、指定された範囲内のセルが数値であることを前提としています。セルに数値以外の値（文字列、エラー値など）が含まれている場合、エラーが発生する可能性があります。これを回避するために、事前にセルの値の型をチェックする処理を追加することが望ましいです。

’
’
Function GetMinMax(rng As Range, Optional ByVal getMin As Boolean = True) As Double
    If getMin Then　’選択範囲からTRUEで最小値を取得
        GetMinMax = Application.WorksheetFunction.Min(rng)
    Else　’選択範囲からFalseで最大値を取得
        GetMinMax = Application.WorksheetFunction.Max(rng)
    End If
End Function
’
’

’

Function GetMinMax(rng As Range, Optional ByVal getMin As Boolean = True) As Double

If getMin Then　’選択範囲からTRUEで最小値を取得

GetMinMax = Application.WorksheetFunction.Min(rng)

Else　’選択範囲からFalseで最大値を取得

GetMinMax = Application.WorksheetFunction.Max(rng)

End If

End Function

’

Excel VBA Functionプロシージャを使いこなす。表範囲を範囲を取得する（開始列・終了列・開始行・終了行）

●プログラム説明　(サンプル②)

下記のサンプルプログラムは、Functionプロシージャを利用して、指定したワークシートの一覧表に対して、その表の範囲・開始列・終了列・開始行・終了行を取得するサンプルプログラムです。EXCEL　VBAプログラムを作成する際に、表の大きさを取得する事は頻繁にあると思いますので、Functionプロシージャを利用して何度も利用する際にはとても便利だと思います。

【プログラムの流れ】
①　ワークシートを設定します。（下記のサンプルプログラムでは、”Sheet1″を設定）
②　表の起点となるセル位置：開始セルを設定します。（下記のサンプルプログラムでは、”B2”を設定）
③　FunctionプロシージャGetTableInfoFromWsを呼び出し、ワークシート①と開始セル②を渡します。
④　GetTableInfoFromWsプロシージャでは、開始行、開始列、最終行、最終列を取得し、表の範囲を計算します。
⑤　計算された範囲、開始行、開始列、最終行、最終列を戻り値として返します。
⑥　メッセージボックスに表の範囲、開始行、開始列、最終行、最終列を表示します。

【プログラムの注意事項】
①　ワークシート名と開始セルは、必要に応じて変更してください。（必ず実在するワークシート名・セルを指定）
②　表のデータが空白を含む場合、最終行や最終列の取得が正しくない場合があります。
③　このプログラムは、表が連続したデータで構成されていることを前提としています。

Option Explicit

'
'
Sub GetTableInfo()
    ' ワークシートを設定
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 開始セルを設定
    Dim startCell As Range
    Set startCell = ws.Range("B2")
    
    ' 関数を呼び出して、表の情報を取得
    Dim tableInfo As Variant
    tableInfo = GetTableInfoFromWs(ws, startCell)
    
    ' 取得した表の情報をメッセージボックスに表示
    MsgBox "表の範囲: " & tableInfo(0) & vbCrLf & _
           "開始行: " & tableInfo(1) & vbCrLf & _
           "開始列: " & tableInfo(2) & vbCrLf & _
           "最終行: " & tableInfo(3) & vbCrLf & _
           "最終列: " & tableInfo(4), vbInformation, "結果"
End Sub

Function GetTableInfoFromWs(ws As Worksheet, startCell As Range) As Variant
    ' 開始行と開始列を取得
    Dim startRow As Long
    Dim startCol As Long
    startRow = startCell.Row
    startCol = startCell.Column
    
    ' 最終行と最終列を取得
    Dim lastRow As Long
    Dim lastCol As Long
    lastRow = startCell.End(xlDown).Row
    lastCol = startCell.End(xlToRight).Column
    
    ' 表の範囲を取得
    Dim tableRange As Range
    Set tableRange = ws.Range(startCell, ws.Cells(lastRow, lastCol))
    
    ' 表の情報を配列に格納
    Dim result(0 To 4) As Variant
    result(0) = tableRange.Address
    result(1) = startRow
    result(2) = startCol
    result(3) = lastRow
    result(4) = lastCol
    
    ' 配列を戻り値として返す
    GetTableInfoFromWs = result
End Function
'
'

Option Explicit

Sub GetTableInfo()

' ワークシートを設定

Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets("Sheet1")

' 開始セルを設定

Dim startCell As Range

Set startCell = ws.Range("B2")

' 関数を呼び出して、表の情報を取得

Dim tableInfo As Variant

tableInfo = GetTableInfoFromWs(ws, startCell)

' 取得した表の情報をメッセージボックスに表示

MsgBox "表の範囲: " & tableInfo(0) & vbCrLf & _

"開始行: " & tableInfo(1) & vbCrLf & _

"開始列: " & tableInfo(2) & vbCrLf & _

"最終行: " & tableInfo(3) & vbCrLf & _

"最終列: " & tableInfo(4), vbInformation, "結果"

End Sub

Function GetTableInfoFromWs(ws As Worksheet, startCell As Range) As Variant

' 開始行と開始列を取得

Dim startRow As Long

Dim startCol As Long

startRow = startCell.Row

startCol = startCell.Column

' 最終行と最終列を取得

Dim lastRow As Long

Dim lastCol As Long

lastRow = startCell.End(xlDown).Row

lastCol = startCell.End(xlToRight).Column

' 表の範囲を取得

Dim tableRange As Range

Set tableRange = ws.Range(startCell, ws.Cells(lastRow, lastCol))

' 表の情報を配列に格納

Dim result(0 To 4) As Variant

result(0) = tableRange.Address

result(1) = startRow

result(2) = startCol

result(3) = lastRow

result(4) = lastCol

' 配列を戻り値として返す

GetTableInfoFromWs = result

End Function

●実行前～実行後　※プログラム実行後、、指定されたワークシートにある表の範囲（A1形式）、開始行、開始列、最終行、最終列がメッセージボックスで表示されます。実際の結果は、ワークシート内のデータに依存します。
（画面クリックして拡大）

Excel VBA Functionプロシージャを使いこなす。繰り返し集計表（マトリックス表）を作成する。

●プログラム説明　(サンプル③)

下記のサンプルプログラムは、Functionプロシージャを利用して、指定したデータ対して、集計表（マトリックス表）を作成するサンプルプログラムです。具体的には、指定された範囲のデータを読み取り、横軸と縦軸のキーに基づいてマトリックス表を作成するものです。入力データとなるワークシート（DATA）からデータを取得し、マトリックス表（集計表）を別のワークシート（表作成）に作成します。マトリックス表を作成する部分は、Functionプロシージャとして再利用可能なため、何度も入力データとなるワークシート名を指定変更することで再利用しマトリックス表を作成する事ができます。

【プログラムの流れ・関数の処理内容】
★このVBAコード全体は、入力データシート（”DATA1″、”DATA2″、”DATA3″）からマトリックスデータを作成し、”表作成”シートに出力するためのものです。
【さらに詳細に説明します。】

1. ExecuteCreateMatrixTable01, ExecuteCreateMatrixTable02, ExecuteCreateMatrixTable03:
１-１ワークシートオブジェクトを作成して、データが格納されているシート（”DATA1″, “DATA2”, “DATA3″）と出力先シート（”表作成”）を指定。
１-２ CreateMatrixTable 関数を呼び出し、引数としてデータシートと出力シートを渡す。

2. CreateMatrixTable(ws As Worksheet, wsOutput As Worksheet):
２-１入力ワークシート（ws）の最後の行と最後の列を取得することで、データ範囲を特定。
２-２入力データの範囲を設定し、Rangeオブジェクトを作成。
２-３ CreateMatrixData 関数を呼び出し、引数として入力データ範囲を渡す。この関数は、マトリックスデータをディクショナリオブジェクトとして返す。
２-４出力先ワークシート（wsOutput）のセルをクリアして、新しいマトリックス表を出力する準備を整える。
２-５ OutputMatrixTable 関数を呼び出し、引数として出力先ワークシートとマトリックスデータのディクショナリを渡す。
２-６出力先ワークシートをアクティブにすることで、結果を表示。

3. CreateMatrixData(rng As Range) As Object:
３-１スクリプトディクショナリオブジェクトを作成して、マトリックスデータを格納するための構造を準備。
３-２入力データの範囲（Rangeオブジェクト）を走査し、各セルのデータをもとにマトリックスデータを作成。
３-３ディクショナリのキーを作成し、既存のキーがない場合はディクショナリに新しいキーを追加。3列目の値を加算して、マトリックスデータを構築。
３-４ディクショナリオブジェクト（マトリックスデータ）を返す。

4. OutputMatrixTable(ws As Worksheet, dict As Object):
４-１行と列のインデックスを格納するためのスクリプトディクショナリオブジェクトを作成。
４-２ディクショナリのキーを使って、一意の行と列のインデックスを設定し、対応するセルにデータを出力する。
４-３マトリックス表に値を入力するために、ディクショナリのキーを走査し、行と列のインデックスを取得。対応するセルにディクショナリの値を入力。
４-４表の範囲を特定し、Rangeオブジェクトを作成。
４-５表の範囲に罫線を適用し、列幅を自動調整して視認性を向上させる。

【プログラム実行条件・注意事項】
①　入力データのワークシート名（DATA1, DATA2, DATA3）と出力先のワークシート名（表作成）は、実際の状況に合わせて変更する必要があります。
②　このコードは、入力データの1列目と2列目が一意であることを前提としています。重複するデータがある場合、マトリックス表の作成が正しく行われません。
③　入力データの3列目のデータは数値であることが前提とされています。数値以外のデータが含まれている場合、エラーが発生するか、正しく計算されない可能性があります。

★【サンプルプログラム】
下記のリンク先よりサンプルプログラムをダウンロードする事ができます。
●　Function40（サンプルプログラム）

’
’
Option Explicit

Sub ExecuteCreateMatrixTable01()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet

    ' ワークシートを設定
    Set ws = ThisWorkbook.Worksheets("DATA1")
    Set wsOutput = ThisWorkbook.Worksheets("表作成")
    
    ' CreateMatrixTable関数を実行
    CreateMatrixTable ws, wsOutput
End Sub


Sub ExecuteCreateMatrixTable02()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet

    ' ワークシートを設定
    Set ws = ThisWorkbook.Worksheets("DATA2")
    Set wsOutput = ThisWorkbook.Worksheets("表作成")
    
    ' CreateMatrixTable関数を実行
    CreateMatrixTable ws, wsOutput
End Sub

Sub ExecuteCreateMatrixTable03()
    Dim ws As Worksheet
    Dim wsOutput As Worksheet

    ' ワークシートを設定
    Set ws = ThisWorkbook.Worksheets("DATA3")
    Set wsOutput = ThisWorkbook.Worksheets("表作成")
    
    ' CreateMatrixTable関数を実行
    CreateMatrixTable ws, wsOutput
End Sub


Function CreateMatrixTable(ws As Worksheet, wsOutput As Worksheet)
    Dim rng As Range
    Dim dict As Object
    Dim lastRow As Long, lastCol As Long
    
    
    ' 最後の行と列を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol))
    
    ' マトリックスデータを作成
    Set dict = CreateMatrixData(rng)
    ' マトリックス表をクリアします。
    wsOutput.Cells.Clear
    ' マトリックス表を出力
    OutputMatrixTable wsOutput, dict
    ' マトリックス表をアクティブにする
    wsOutput.Activate
    
End Function

Function CreateMatrixData(rng As Range) As Object
    Dim dict As Object
    Dim cell As Range
    Dim key As String

    ' スクリプトディクショナリオブジェクトを作成
    Set dict = CreateObject("Scripting.Dictionary")

    ' セルを走査してマトリックスデータを作成
    For Each cell In rng.Cells
        If cell.Column = 1 Then
            key = cell.Value
        ElseIf cell.Column = 2 Then
            key = key & "_" & cell.Value
            If Not dict.Exists(key) Then
                dict.Add key, 0
            End If
        ElseIf cell.Column = 3 Then
            dict(key) = dict(key) + cell.Value
        End If
    Next cell

    ' マトリックスデータオブジェクトを返す
    Set CreateMatrixData = dict
End Function

Sub OutputMatrixTable(ws As Worksheet, dict As Object)
    Dim key As Variant
    Dim keys As Variant
    Dim k As Variant
    Dim row As Long
    Dim col As Long
    Dim rowIndex As Object, columnIndex As Object
    Dim r As Long, c As Long
    Dim rngTable As Range

    ' 行と列のインデックスディクショナリを作成
    Set rowIndex = CreateObject("Scripting.Dictionary")
    Set columnIndex = CreateObject("Scripting.Dictionary")

    row = 2
    col = 2

    ' 一意の行と列のインデックスを設定
    For Each key In dict.keys
        keys = Split(key, "_")

        If Not rowIndex.Exists(keys(0)) Then
            rowIndex.Add keys(0), row
            ws.Cells(row, 1).Value = keys(0)
            row = row + 1
        End If

        If Not columnIndex.Exists(keys(1)) Then
            columnIndex.Add keys(1), col
            ws.Cells(1, col).Value = keys(1)
            col = col + 1
        End If
    Next key
    
        ' マトリックス表に値を入力
    For Each key In dict.keys
        keys = Split(key, "_")
        r = rowIndex(keys(0))
        c = columnIndex(keys(1))
        ws.Cells(r, c).Value = dict(key)
    Next key

    ' 表の範囲を特定
    Set rngTable = ws.Range(ws.Cells(1, 1), ws.Cells(row - 1, col - 1))

    ' 罫線を適用し、列幅を自動調整
    With rngTable
        .Borders.LineStyle = xlContinuous
        .EntireColumn.AutoFit
    End With
End Sub
’
’

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

’

Option Explicit

Sub ExecuteCreateMatrixTable01()

Dim ws As Worksheet

Dim wsOutput As Worksheet

' ワークシートを設定

Set ws = ThisWorkbook.Worksheets("DATA1")

Set wsOutput = ThisWorkbook.Worksheets("表作成")

' CreateMatrixTable関数を実行

CreateMatrixTable ws, wsOutput

End Sub

Sub ExecuteCreateMatrixTable02()

Dim ws As Worksheet

Dim wsOutput As Worksheet

' ワークシートを設定

Set ws = ThisWorkbook.Worksheets("DATA2")

Set wsOutput = ThisWorkbook.Worksheets("表作成")

' CreateMatrixTable関数を実行

CreateMatrixTable ws, wsOutput

End Sub

Sub ExecuteCreateMatrixTable03()

Dim ws As Worksheet

Dim wsOutput As Worksheet

' ワークシートを設定

Set ws = ThisWorkbook.Worksheets("DATA3")

Set wsOutput = ThisWorkbook.Worksheets("表作成")

' CreateMatrixTable関数を実行

CreateMatrixTable ws, wsOutput

End Sub

Function CreateMatrixTable(ws As Worksheet, wsOutput As Worksheet)

Dim rng As Range

Dim dict As Object

Dim lastRow As Long, lastCol As Long

' 最後の行と列を取得

lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row

lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol))

' マトリックスデータを作成

Set dict = CreateMatrixData(rng)

' マトリックス表をクリアします。

wsOutput.Cells.Clear

' マトリックス表を出力

OutputMatrixTable wsOutput, dict

' マトリックス表をアクティブにする

wsOutput.Activate

End Function

Function CreateMatrixData(rng As Range) As Object

Dim dict As Object

Dim cell As Range

Dim key As String

' スクリプトディクショナリオブジェクトを作成

Set dict = CreateObject("Scripting.Dictionary")

' セルを走査してマトリックスデータを作成

For Each cell In rng.Cells

If cell.Column = 1 Then

key = cell.Value

ElseIf cell.Column = 2 Then

key = key & "_" & cell.Value

If Not dict.Exists(key) Then

dict.Add key, 0

End If

ElseIf cell.Column = 3 Then

dict(key) = dict(key) + cell.Value

End If

Next cell

' マトリックスデータオブジェクトを返す

Set CreateMatrixData = dict

End Function

Sub OutputMatrixTable(ws As Worksheet, dict As Object)

Dim key As Variant

Dim keys As Variant

Dim k As Variant

Dim row As Long

Dim col As Long

Dim rowIndex As Object, columnIndex As Object

Dim r As Long, c As Long

Dim rngTable As Range

' 行と列のインデックスディクショナリを作成

Set rowIndex = CreateObject("Scripting.Dictionary")

Set columnIndex = CreateObject("Scripting.Dictionary")

row = 2

col = 2

' 一意の行と列のインデックスを設定

For Each key In dict.keys

keys = Split(key, "_")

If Not rowIndex.Exists(keys(0)) Then

rowIndex.Add keys(0), row

ws.Cells(row, 1).Value = keys(0)

row = row + 1

End If

If Not columnIndex.Exists(keys(1)) Then

columnIndex.Add keys(1), col

ws.Cells(1, col).Value = keys(1)

col = col + 1

End If

Next key

' マトリックス表に値を入力

For Each key In dict.keys

keys = Split(key, "_")

r = rowIndex(keys(0))

c = columnIndex(keys(1))

ws.Cells(r, c).Value = dict(key)

Next key

' 表の範囲を特定

Set rngTable = ws.Range(ws.Cells(1, 1), ws.Cells(row - 1, col - 1))

' 罫線を適用し、列幅を自動調整

With rngTable

.Borders.LineStyle = xlContinuous

.EntireColumn.AutoFit

End With

End Sub

’

●実行前～実行後　※このコードを実行すると、指定された入力データのワークシートからマトリックス表が作成され、”表作成”のワークシートに出力されます。マトリックス表は、行と列が入力データの1列目と2列目のデータに基づいて分類され、対応する交差点のセルに3列目のデータが加算された状態で表示されます。また、罫線が適用され、列幅が自動調整されています。
（画面クリックして拡大）