【VBA】Excelで連動するプルダウンを作りたい

WEBではよく見かける「連動する大項目→中項目→小項目」をExcel上で作成要望を受けたので作ってみたのですが、ボチボチ需要ある？と思って書き残してみました

VBAを使わなくても実現できるんですが、条件付きだったりマスタがわかりにくくなるので今回はVBA前提バージョンです

連動するプルダウンの具体例
仕様の解説
あとがき

連動するプルダウンの具体例

タイトルの通りなので改めて説明する必要もないかもですが念のため・・・

例えば左のようなマスタテーブルがあった時

大項目で”大項目1″を選ぶと中項目は「中項目1、中項目2、中項目5」のいずれかを選ぶプルダウンになる
中項目で”中項目1″を選ぶと小項目は「小項目1、小項目2、小項目3、小項目4、小項目5」のいずれかを選ぶプルダウンになる
大項目、中項目、小項目の組み合わせで結果を照合する

ポイントはマスタの中項目が飛び飛びでもOK、小項目が重複しても大項目・中項目との組み合わせでユニークになる表なので例えば”小項目6″を選んでも結果はFとQが返却されるパターンがあるところ

このページの最後に実際のエクセルファイルを置いてますので気になる方はダウンロードしてみてください

仕様の解説

なるべく細かく仕様の説明を書いていきますので細かい話に興味がない人は最下部にある全ソースやダウンロードできるサンプルファイルを見てください

肝心のExcel構成はこんな感じ

プルダウン機能は入力規則を使っていて大項目、中項目、小項目を順番に選ぶとマスタテーブルに沿った結果が反映するようにします※結果はマクロでも反映させます（F3セル）がXLOOKUP関数でも反映できます（F6セル）ので参考まで

タイトルの通り大項目・中項目・小項目は連動していて入力規則の元の値をVBAで書き換える仕様にしています

ついでに名前管理してるとVBAでも使えるので可読性が上がる気がするので個人的にはオススメ機能

VBAを書く場所とモジュール

今回は値の変更をトリガーにする必要があるので標準モジュールではなくシートモジュールで”Worksheet”、”Change”で作成します

列番号は列挙型で宣言しておくのがオススメ

VBAはプログラムの中で列番号を指定することが多いのでEnumで列番号をセットしておくのがオススメ

Excelは一覧だったりマスタ用のテーブルだったり後から項目足したり削除したり変更することが多く、メンテナンスのことを考えると結構重宝します

'--- 列挙型で列番号を定めておく
Enum lngCol
    item1 = 2
    item2
    item3
    result = 6
End Enum

メインプログラム

“Worksheet_Change”モジュールなのでシート内の値が変更されればプログラムが実行されるのは良いんですがどこでも発火しちゃうのでTargetのAddressと名前管理したセルのAddressが一致した時に処理が実行されるようにSelect Caseで照合ついでの条件分岐しておく

Rangeの指定をアドレスじゃなくて名前にしているのが最初に書いた名前管理の賜物

VBAの中で定数や変数にする派の人もいるのでお好みで

Private Sub Worksheet_Change(ByVal Target As Range)
'====================================================================================================
' 処理がわかりやすいようにセルに名前をつけて連動するプルダウン項目を作る
' Worksheet_Changeを発火トリガーにしてセルの値が変わったら動くプログラムにする
'====================================================================================================

'更新されたセルが名前を付けたセルと一致していたらプログラム実行する
On Error GoTo ErrLabel
    Select Case Target.Address
        Case Range("ITEM1").Address
            '--- 大項目のセルが更新されたら中項目の入力規則を変更する
            With Range("ITEM2").Validation
                '--- 一旦入力規則を削除
                .Delete
                '--- DeleteやBackSpaceでセルがクリアされたら処理しない
                If Len(Target.Value) > 0 Then
                    '--- 入力値の種類をリスト形式にして、リストの値はサブルーチンで生成する ※入力規則の設定は最低限にしているので他項目はお好みで
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=add_item_list(1, Range("ITEM1").Value, Range("ITEM2").Value, Range("ITEM3").Value)
                End If
            End With
            '--- 大項目が更新されたら中項目・小項目と結果の値をクリアする ※イベントを一時的に無効化しないと動きがおかしくなる
            Application.EnableEvents = False
            Range("ITEM2").ClearContents
            Range("ITEM3").ClearContents
            Range("ITEM3").Validation.Delete
            Range("RESULT").Value = "-"
            Application.EnableEvents = True
        
        Case Range("ITEM2").Address
            '--- 中項目のセルが更新されたら小項目の入力規則を変更する
            With Range("ITEM3").Validation
                '--- 一旦入力規則を削除
                .Delete
                '--- DeleteやBackSpaceでセルがクリアされたら処理しない
                If Len(Target.Value) > 0 Then
                    '--- 入力値の種類をリスト形式にして、リストの値はサブルーチンで生成する ※入力規則の設定は最低限にしているので他項目はお好みで
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=add_item_list(2, Range("ITEM1").Value, Range("ITEM2").Value, Range("ITEM3").Value)
                End If
            End With
            '--- 中項目が更新されたら小項目と結果の値をクリアする ※イベントを一時的に無効化しないと動きがおかしくなる
            Application.EnableEvents = False
            Range("ITEM3").ClearContents
            Range("RESULT").Value = "-"
            Application.EnableEvents = True
        Case Range("ITEM3").Address
            '--- DeleteやBackSpaceでセルがクリアされた場合の処理
            Range("RESULT").Value = add_item_list(4, Range("ITEM1").Value, Range("ITEM2").Value, Range("ITEM3").Value)
    End Select
On Error GoTo 0
Exit Sub

ErrLabel:
Application.EnableEvents = True
MsgBox "予期せぬエラーが発生しました", vbCritical
End Sub

プルダウンの選択肢を作るサブルーチン

肝になるマスタテーブルを参照してプルダウンの選択肢を作るプログラム

前提として入力規則でプルダウンを作るには”小項目6,小項目7,小項目8,小項目9,小項目10″のようにカンマ区切りの文字を作ってあげればOKなので戻り値はこの形で

引数levelでどの項目を取得したいのか指定することでどの項目まで一致する必要があるのか、返す値がどの列なのか判定してます

Function add_item_list(level As Long, item1 As String, item2 As String, item3 As String) As String
'====================================================================================================
' マスタシートにある項目マスタから入力規則用の配列形式の文字列を返すサブルーチン
' 重複しないリストにしたいのでDictionary型で重複除外しながら値を収集する仕様
'   level:取得したい項目「中項目→1、小項目→2、欠番→3、結果→4」
'   item1:大項目の値
'   item2:中項目の値
'   item3:小項目の値
'====================================================================================================
Dim lngRow As Long
Dim objDic As New Scripting.Dictionary

With Sheet2
    ' ---表の一番上から一番下までループして一致している値だけ収集する ※テーブル化した方が良いかもしれない
    For lngRow = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
        ' ---対象の項目の値が一致するかlevelより大きい場合に次のレベルとの照合をする
        If .Cells(lngRow, lngCol.item1).Value = item1 Or level < 1 Then
            If .Cells(lngRow, lngCol.item2).Value = item2 Or level < 2 Then
                If .Cells(lngRow, lngCol.item3).Value = item3 Or level < 3 Then
                    '--- まだ取得していない項目なら追加する
                    If objDic.Exists(.Cells(lngRow, level + 2).Value) = False Then
                        '--- 列の位置は表に合わせて調整 ※今回はA列を空けているのでlevel+2が対象列になる
                        objDic.Add .Cells(lngRow, level + 2).Value, .Cells(lngRow, level + 2).Value
                    End If
                End If
            End If
        End If
    Next
End With
' ---結果を取得する時に該当がなかったら"-"を返すようにしておく
If level = 4 And objDic.Count = 0 Then objDic.Add "-", "-"
' --- 最後にカンマ区切りでJoinしてあげると入力規則用で使える配列形式の文字列にできる
add_item_list = Join(objDic.Keys, ",")
End Function

全ソース

全部くっつけただけのソースなので説明は↑で

VBAの全ソース

Option Explicit
'--- 列挙型で列番号を定めておく
Enum lngCol
    item1 = 2
    item2
    item3
    result = 6
End Enum
Private Sub Worksheet_Change(ByVal Target As Range)
'====================================================================================================
' 処理がわかりやすいようにセルに名前をつけて連動するプルダウン項目を作る
' Worksheet_Changeを発火トリガーにしてセルの値が変わったら動くプログラムにする
'====================================================================================================

'更新されたセルが名前を付けたセルと一致していたらプログラム実行する
On Error GoTo ErrLabel
    Select Case Target.Address
        Case Range("ITEM1").Address
            '--- 大項目のセルが更新されたら中項目の入力規則を変更する
            With Range("ITEM2").Validation
                '--- 一旦入力規則を削除
                .Delete
                '--- DeleteやBackSpaceでセルがクリアされたら処理しない
                If Len(Target.Value) > 0 Then
                    '--- 入力値の種類をリスト形式にして、リストの値はサブルーチンで生成する ※入力規則の設定は最低限にしているので他項目はお好みで
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=add_item_list(1, Range("ITEM1").Value, Range("ITEM2").Value, Range("ITEM3").Value)
                End If
            End With
            '--- 大項目が更新されたら中項目・小項目と結果の値をクリアする ※イベントを一時的に無効化しないと動きがおかしくなる
            Application.EnableEvents = False
            Range("ITEM2").ClearContents
            Range("ITEM3").ClearContents
            Range("ITEM3").Validation.Delete
            Range("RESULT").Value = "-"
            Application.EnableEvents = True
        
        Case Range("ITEM2").Address
            '--- 中項目のセルが更新されたら小項目の入力規則を変更する
            With Range("ITEM3").Validation
                '--- 一旦入力規則を削除
                .Delete
                '--- DeleteやBackSpaceでセルがクリアされたら処理しない
                If Len(Target.Value) > 0 Then
                    '--- 入力値の種類をリスト形式にして、リストの値はサブルーチンで生成する ※入力規則の設定は最低限にしているので他項目はお好みで
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=add_item_list(2, Range("ITEM1").Value, Range("ITEM2").Value, Range("ITEM3").Value)
                End If
            End With
            '--- 中項目が更新されたら小項目と結果の値をクリアする ※イベントを一時的に無効化しないと動きがおかしくなる
            Application.EnableEvents = False
            Range("ITEM3").ClearContents
            Range("RESULT").Value = "-"
            Application.EnableEvents = True
        Case Range("ITEM3").Address
            '--- DeleteやBackSpaceでセルがクリアされた場合の処理
            Range("RESULT").Value = add_item_list(4, Range("ITEM1").Value, Range("ITEM2").Value, Range("ITEM3").Value)
    End Select
On Error GoTo 0
Exit Sub

ErrLabel:
Application.EnableEvents = True
MsgBox "予期せぬエラーが発生しました", vbCritical
End Sub
Function add_item_list(level As Long, item1 As String, item2 As String, item3 As String) As String
'====================================================================================================
' マスタシートにある項目マスタから入力規則用の配列形式の文字列を返すサブルーチン
' 重複しないリストにしたいのでDictionary型で重複除外しながら値を収集する仕様
'   level:大項目→1、中項目→2、小項目→3
'   item1:大項目の値
'   item2:中項目の値
'   item3:小項目の値
'====================================================================================================
Dim lngRow As Long
Dim objDic As New Scripting.Dictionary

With Sheet2
    ' ---表の一番上から一番下までループして一致している値だけ収集する ※テーブル化した方が良いかもしれない
    For lngRow = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
        ' ---対象の項目の値が一致するかlevelより大きい場合に次のレベルとの照合をする
        If .Cells(lngRow, lngCol.item1).Value = item1 Or level < 1 Then
            If .Cells(lngRow, lngCol.item2).Value = item2 Or level < 2 Then
                If .Cells(lngRow, lngCol.item3).Value = item3 Or level < 3 Then
                    '--- まだ取得していない項目なら追加する
                    If objDic.Exists(.Cells(lngRow, level + 2).Value) = False Then
                        '--- 列の位置は表に合わせて調整 ※今回はA列を空けているのでlevel+2が対象列になる
                        objDic.Add .Cells(lngRow, level + 2).Value, .Cells(lngRow, level + 2).Value
                    End If
                End If
            End If
        End If
    Next
End With
' ---結果を取得
If level = 4 And objDic.Count = 0 Then objDic.Add "-", "-"
'--- 最後にカンマ区切りでJoinしてあげると入力規則用で使える配列形式の文字列にできる
add_item_list = Join(objDic.Keys, ",")
End Function