データの入力規則：リストをキーワードに併せて変更

週末に職場で、このような課題に直面した。

あるキーワードに併せて、データの入力規則：リストを変更したい。

いつもの「なんちゃって個人情報」を、今回も拝借。
例えば「茨城県」の「名前」を選択したとき、左の表から茨城県の戸塚さんと飯田さんをリスト表示したいのだ。
f:id:Infoment:20200426214447p:plain

そこで、月曜日の朝から全開で仕事ができるよう、休みの間に
仕組みだけ作っておくことにした。
f:id:Infoment:20200426214625p:plain

マクロを使う、関数を使うなど色々な方法がある中で、今回はこの方式を採用。

件名をkeyに、表示する名前をItemとして、辞書（連想配列）を作成する。
実際の名前セルを選択したとき、SelectionChangeイベントでリスト更新。
※更新内容は、1. で作成したitemとする。

実際に作成したのが ↓ こちら。
※今回はシートモジュールに作成。

Option Explicit
Enum ColumnNumber
    cnNo = 1
    cn名前
    cn都道府県
    [_eLast]
End Enum

' リスト設定用サブプロシージャ。
Sub SetValidation(target_range As Range, list_char As String)
    Dim Validation As Validation
    Set Validation = target_range.Validation
    
    If list_char = vbNullString Then
        list_char = "該当なし"
    End If

    With Validation
        ' リストを一旦リセット。
        .Delete
        ' リスト追加。
        .Add Type:=xlValidateList, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:=list_char
        .IgnoreBlank = True
        .InCellDropdown = True
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
End Sub

' 元のテーブル。
Private Property Get SourceTable() As ListObject
    Set SourceTable = Me.ListObjects(1)
End Property

' リストを設定するテーブル。
Private Property Get ListTable() As ListObject
    Set ListTable = Me.ListObjects(2)
End Property

' 元のテーブルから、リスト表示用文字列を作成する辞書。
Private Property Get Dict() As Scripting.Dictionary
    Static TempDict As Scripting.Dictionary
        If TempDict Is Nothing Then
            Set TempDict = New Scripting.Dictionary
            Dim ListRow As Excel.ListRow
                For Each ListRow In SourceTable.ListRows
                    With ListRow.Range
                        If TempDict.Exists(.Cells(cn都道府県).Value) Then
                            TempDict(.Cells(cn都道府県).Value) = TempDict(.Cells(cn都道府県).Value) & "," & .Cells(cn名前).Value
                        Else
                            TempDict(.Cells(cn都道府県).Value) = .Cells(cn名前).Value
                        End If
                    End With
                Next
        End If
        Set Dict = TempDict
End Property

' リストを設定したいセルを選択した時のイベント。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' ２個以上のセル同時選択は無効。
    If Target.Count >= 2 Then
    ' 「名前」列以外を選択した場合無効。
    ElseIf Intersect(Target, ListTable.ListColumns("名前").DataBodyRange) Is Nothing Then
    ' リスト設定。
    Else
        SetValidation Target, Dict(Target.Offset(, -1).Value)
    End If
End Sub