Excel VBA カスタマイズ可能なドロップダウンリストを作成する方法: 入力値に基づくバリデーションの活用

Sub CreateDropdown()
    Dim dropdownRange As Range
    Dim inputRange As Range

    Set inputRange = Sheet1.Range("A1:A3")   ' ドロップダウンリストの選択肢が含まれる範囲
    Set dropdownRange = Sheet1.Range("B1")   ' ドロップダウンリストを設置するセル

    With dropdownRange.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=A1:A3"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Sub SetValidation()
    Dim validationRange As Range

    Set validationRange = Sheet1.Range("C1")  ' バリデーションを設定するセル

    With validationRange.Validation
        .Delete
        .Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
        Operator:=xlBetween, Formula1:="1", Formula2:="10"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim FirstList As Range
    Dim SecondList As Range

    Set FirstList = ThisWorkbook.Sheets("Sheet1").Range("A1")  ' 最初のドロップダウンリスト
    Set SecondList = ThisWorkbook.Sheets("Sheet1").Range("B1") ' 二つ目のドロップダウンリスト

    ' 最初のリストが変更されたときにのみ動作
    If Not Intersect(Target, FirstList) Is Nothing Then
        Call UpdateSecondList(FirstList.Value, SecondList)
    End If
End Sub

Private Sub UpdateSecondList(ByVal SelectedValue As String, ByVal SecondList As Range)
    Dim OptionsArray As Variant

    ' 選択肢を選択した値に基づいて設定
    If SelectedValue = "オプション1" Then
        OptionsArray = Array("1A", "1B", "1C")
    ElseIf SelectedValue = "オプション2" Then
        OptionsArray = Array("2A", "2B", "2C")
    Else
        OptionsArray = Array()
    End If

    ' 二つ目のドロップダウンリストの更新
    With SecondList.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(OptionsArray, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
End Sub