[[20210302204123]]　『ドロップダウンリストをVBAで』（乾燥肌）　ページの最後に飛ぶ

『ドロップダウンリストをVBAで』（乾燥肌）

現在、2段階のドロップダウンリストを使用しておりますが、
それでも選択肢が多いです（それぞれ選択肢が50程度）。

既存のドロップダウンリストでは表示数が8個しかなく、
また、マウスホイールで上下移動ができないため不便を感じております。

そのため、VBAで多数の選択肢を表示可能な2段階or3段階のドロップダウンリストを作成したいのですが、
当方、VBAを学び始めて1ヶ月ほどのため、基礎的な処理はある程度できますが、ドロップダウンリストはどのように作れば良いか、全く分からず頓挫しております。

どなたかお助けいただけないでしょうか。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

https://excel-ubara.com/excelvba3/EXCELFORM018.html

（推奨） 2021/03/02(火) 21:00

 おはようございます　＾＾
いろんな方法が有るとは思いますが、一案
で。いずれにいたしましても、三連させる
なら大、中、小、分類で三シートに分けて
リレーショナブルなリスト情報を作成する
と比較的、解りやすい様な気がいたします。
範囲名を乱用すると、。。私は混乱しやす
いので。＾＾；
オフセットと、リサイズ方式で、リスト情
報さえ、作成してしまえば、あとは、入力
規則作成するだけの様に思いますです。。
。いや。。。ほんと思うだけで。。。あい
すみません。。m(_ _)m
（隠居じーさん） 2021/03/03(水) 06:34

確認が遅くなり申し訳ございません。
お二方ともありがとうございます。

推奨様のリンク先を元に2段階のコンボボックスを作成してみました。
文字サイズ等も自由に設定でき、使いやすいと感じました。

現在以下のようになっております。

 ________________________________
 Private Sub UserForm_Initialize()

     aryテスト = Worksheets("動作テスト").Cells(1, 1).CurrentRegion
     Dim i As Long
     With Me.cmbテスト1
         .Clear
         For i = 1 To UBound(aryテスト, 2)
             .AddItem aryテスト(1, i)
         Next
     End With
 End Sub
 ________________________________
 Private aryテスト
 Private Sub cmbテスト1_Change()
     Dim i As Long
     Dim j As Long
     j = Me.cmbテスト1.ListIndex + 1
     With Me.cmbテスト2
         .Clear
         For i = 2 To UBound(aryテスト, 1)
             If aryテスト(i, j) <> "" Then
                 .AddItem aryテスト(i, j)
             End If
         Next
     End With
 End Sub
 ________________________________

お聞きしたいのですが、
大分類→中分類　で終わるものもあれば、
大分類→中分類→小分類　で終わるものもあれば、
大分類→中分類→小分類→小小分類　で終わるものもあります。

中分類で終わりの場合、これで終わりと分かるようにしたいです。
逆に、小分類まである場合、小分類まで選択していないと「小分類まで選択して下さい」のようなポップアップ表示を出したいです。

どのようなコードを組めばよいでしょうか？
また、その場合、各シートへのデータはどのように保存すると管理しやすいのでしょうか？
難しいと思いますが、よろしくお願いします。
（乾燥肌） 2021/03/04(木) 10:46

 おはようございます　＾＾
 シート名　データ一覧
    |[A]       |[B]     |[C]       
 [1]|都道府県名|店舗名  |顧客名    
 [2]|愛知県    |CBW-店舗|顧客Y001AV
 [3]|愛知県    |CBW-店舗|顧客G001XQ

        |[A]     |[B]     |[C]       
 [18647]|和歌山県|NHL-店舗|顧客W047PG
 [18648]|和歌山県|NHL-店舗|顧客X047JG
 シート名　Large
    |[A]   
 [1]|大分類
 [2]|北海道
 [3]|青森県

      |[A]     
 [46]|宮崎県  
 [47]|鹿児島県
 [48]|沖縄県

 シート名　Medium
    |[A]     |[B]     
 [1]|上位分類|中分類  
 [2]|北海道  |ITU-店舗
 [3]|北海道  |ZTX-店舗
 [4]|北海道  |LYP-店舗

 シート名　Small
    |[A]            |[B]       
 [1]|上位分類       |小分類    
 [2]|北海道_ITU-店舗|顧客T046BM
 [3]|北海道_ITU-店舗|顧客E046ND
 [4]|北海道_ITU-店舗|顧客L046DM
 [5]|北海道_ITU-店舗|顧客A046TO
 [6]|北海道_ITU-店舗|顧客J046YZ
 みたいな感じです。都道府県名、若しくは、上位分類で並び替
えしてます。
後は、マクロなしで、数式のＯＦＦＳＥＴ関数、
ＭＡＴＣＨ、ＣＯＵＮＴＩＦ、ＣＯＵＮＴＡ、等を使用して入力
規則のリストを作成するかご希望の様に付録便利機能を付ける場
合は、シートのＣＨＡＮＧＥイベントを活用して、最初の大分類
プルダウン以外はマクロで毎回、大分類のプルダウン時にマクロ
で自動作製するかですね。←この場合、大分類のセル値が変わら
ないと中分類以降は作成されませんので、注意喚起は必要ないか
もと思いすです。＾＾；
一度作成すれば。。。ですが。。。元のデータ一覧に匹敵する情
報が、度々更新される場合はデーターのコンバート[シート作成]
もマクロですれば便利です。と思います。でわでわ。頑張ってく
ださいね。m(_ _)m
（隠居じーさん） 2021/03/04(木) 11:30

＞＞お聞きしたいのですが、
＞＞大分類→中分類　で終わるものもあれば、
＞＞大分類→中分類→小分類　で終わるものもあれば、
＞＞大分類→中分類→小分類→小小分類　で終わるものもあります。
情報も、分ける、基準も想像でしかありませんので。断言は出来ませんが。
ひとつづつ分けて別入力とした方が、不測の事態を軽減できるような気が
致します。私の頭がショートしてきましたので。他の回答者様のアドバイ
スを、お待ちくださいませ。お役に立てず、相済みませんでした。<< _ _ >>

（隠居じーさん） 2021/03/04(木) 12:34

＞中分類で終わりの場合、これで終わりと分かるようにしたいです。
単なる思いつきですが、
終わりになるものには、表示する文字列の最後に
"業種A/"
のようにスラッシュをつけるようにしてはどうですか？
Right(s,1) が"/"で無いときだけ、下位の分類を表示すればよいのでは？

スラッシュをつけるのは表示だけであって、
処理に使用する文字列は、スラッシュを消去したものを使います。

（γ） 2021/03/04(木) 14:48

ユーザーフォームを開いた直後は、
「大分類」以外は使用不可(Enabled=False)にしておいて、
選択したときに、次のコンボボックスのリストがあったら、
使用可能にしていくというユーザーインターフェイスはどうでしょうか。

リストデータの持ち方は、下記のような感じが扱いやすそうです。

大分類　中分類　小分類　小小分類
A　　　　a　　　あ　　　ア
A　　　　a　　　あ　　　イ
A　　　　a　　　い　　　ウ
A　　　　b　　　う
A　　　　b

重複が出るのでDictionaryで重複排除したリストを作成するようにすればいいでしょう。
Dictionaryのアイテムに次のリストのDictionaryを格納するようにするといいですね。

以前、そのようなものを作成したことがあります。
（hatena） 2021/03/04(木) 16:03

大、中、小、小小・・・に分けられる分類リストを試作してみました。
重層化対応でコンマ区切りの文字列にしています。
コンマの個数またはSplitしたときのUboundの値超えで子分類無しの判定ができれば。

    Function Sample(rng As Range) As Variant
        Dim dic As Object
        Dim tmp As Variant
        Dim var As Variant
        Dim str As String
        Dim i As Long, j As Long, k As Long
        Set dic = CreateObject("Scripting.Dictionary")
        var = rng.Value
        ReDim tmp(0 To UBound(var, 2) - 1)
        For i = 1 To UBound(var, 2)
            For j = 1 To UBound(var, 1)
                For k = 1 To i
                    If IsEmpty(var(j, k)) Then Exit For
                    str = str & var(j, k) & ","
                Next k
                str = Left(str, Len(str) - 1)
                If Not dic.exists(str) Then dic.Add str, str
                str = ""
            Next j
            tmp(i - 1) = dic.keys
            dic.RemoveAll
        Next i
        Sample = tmp
    End Function

（Sinking Time） 2021/03/04(木) 16:38

隠居じーさん様
ありがとうございます。
データリスト作成時に参考にさせていただきます。

γ様
ありがとうございます。
"/"を利用する方法、参考にさせていただきます。

hatena様
ありがとうございます。
リスト作成に関して、参考にさせていただきます。

Sinking Time様
ありがとうございます。
今日は時間がないため、週末に確認させていただきます。

（乾燥肌） 2021/03/05(金) 09:14

拙い頭を捻ってまた試作してみました。
「動作テスト」シートのA1から分類リストを作成し
A列を大分類
B列を中分類
C列を小分類
D列を小小分類
にしてください。

ユーザーフォームをつくり
「Label_l」「Label_m」「Label_s」「Label_ss」
「ComboBox_l」「ComboBox_m」「ComboBox_s」「ComboBox_ss」
を置いてください。
下記のコードをユーザーフォームのモジュールに写してください。

下の階層の分類があれば新たにコンボボックスが現れます。
下の階層の分類がなければメッセージボックスに表示します。

    Private Const DLT As String = ","　'←データの中に「,」が含まれる場合は誤作動するのでここを別の文字に変える
    Private Classification As Variant
    Private cName(1) As String
    Private cVol(3) As String
    Private Str(3) As String

    Private Sub UserForm_Initialize()
        Classification = Sample(Worksheets("動作テスト").Cells(1, 1).CurrentRegion)
        cName(0) = "Label"
        cName(1) = "ComboBox"
        cVol(0) = "_l"
        cVol(1) = "_m"
        cVol(2) = "_s"
        cVol(3) = "_ss"
        Str(1) = "(中分類なし)"
        Str(2) = "(小分類なし)"
        Str(3) = "(小小分類なし)"

        With Me.Controls(cName(1) & cVol(0))
            .Clear
            .List = Classification(0)
        End With
        ControlsVisible False, 1
    End Sub

    Private Sub ComboBox_l_click()
        Sample0 0
    End Sub

    Private Sub ComboBox_m_click()
        Sample0 1
    End Sub

    Private Sub ComboBox_s_click()
        Sample0 2
    End Sub

    Private Sub ComboBox_ss_Click()
        Sample0 3
    End Sub

    Private Sub Sample0(n)
        Select Case True
            Case Me.Controls(cName(1) & cVol(n)).Value = Str(n): Sample1 n - 1
            Case n = UBound(cVol): Sample1 n
            Case Else: Sample2 n
        End Select
    End Sub

    Private Sub Sample1(n)
        Dim tmp As String
        Dim i As Long
        For i = LBound(cVol) To n
            tmp = tmp & Me.Controls(cName(1) & cVol(i)).Value & DLT
        Next
        tmp = Left(tmp, Len(tmp) - Len(DLT))
        ControlsVisible False, n + 1
        MsgBox tmp
    End Sub

    Private Sub Sample2(n)
        Dim tmp() As String
        Dim v As Variant
        Dim n1 As Long
        Dim i As Long, j As Long
        n1 = n + 1
        ControlsVisible False, n1
        ReDim tmp(LBound(Classification(n1)) To UBound(Classification(n1)))
        j = LBound(tmp) - 1
        For i = LBound(Classification(n1)) To UBound(Classification(n1))
            v = Split(Classification(n1)(i), DLT)
            If Sample3(v, n) Then
                j = j + 1
                If UBound(v) > n Then
                    tmp(j) = v(n1)
                Else
                    tmp(j) = Str(n1)
                End If
            End If
        Next i
        If j >= LBound(tmp) Then
            ReDim Preserve tmp(j)
            ControlsVisible True, n1
            With Me.Controls(cName(1) & cVol(n1))
                .Clear
                .List = tmp
            End With
            If j = LBound(tmp) And tmp(LBound(tmp)) = Str(n1) Then Sample1 n
        End If
    End Sub

    Private Function Sample3(v, n) As Boolean
        Dim i As Long
        For i = LBound(v) To n
            Select Case True
                Case i > UBound(v): Exit Function
                Case Me.Controls(cName(1) & cVol(i)).Value <> v(i): Exit Function
            End Select
        Next i
        Sample3 = True
    End Function

    Private Sub ControlsVisible(IsVisible As Boolean, n As Long)
        Dim lb As Long, ub As Long
        Dim i As Long, j As Long
        If n < LBound(cVol) Or n > UBound(cVol) Then Exit Sub
        If IsVisible Then
            lb = LBound(cVol): ub = n
        Else
            lb = n: ub = UBound(cVol)
        End If
        For i = lb To ub
            For j = LBound(cName) To UBound(cName)
                Me.Controls(cName(j) & cVol(i)).Visible = IsVisible
            Next
        Next
    End Sub

    Function Sample(rng As Range) As Variant
        Dim dic As Object
        Dim tmp As Variant
        Dim var As Variant
        Dim Str As String
        Dim i As Long, j As Long, k As Long
        Set dic = CreateObject("Scripting.Dictionary")
        var = rng.Value
        ReDim tmp(0 To UBound(var, 2) - 1)
        For i = 1 To UBound(var, 2)
            For j = 1 To UBound(var, 1)
                For k = 1 To i
                    If IsEmpty(var(j, k)) Then Exit For
                    Str = Str & var(j, k) & DLT
                Next k
                Str = Left(Str, Len(Str) - Len(DLT))
                If Not dic.exists(Str) Then dic.Add Str, Str
                Str = ""
            Next j
            tmp(i - 1) = dic.keys
            dic.RemoveAll
        Next i
        Sample = tmp
    End Function

（Sinking Time） 2021/03/05(金) 15:19

「以前、そのようなものを作成したことがあります。」と上の回答で書きましたが、見つけました。
下記で回答してました。

VBA - VBA ユーザーフォーム　コンボボックスについて｜teratail
https://teratail.com/questions/297359

DictionaryのKeyにリストを格納して、アイテムに次のリストのDictionaryを格納する、という入れ子構造にすべてのリストを格納して、コンボボックスを選択したときにそのリストを取得するというロジックになってます。これを元に今回の要件にあうように改造してみました。

リストデータは「ListData」シートに下記のように入力します。

ユーザーフォームにはコンボボックスを４つ（ComboBox1, ComboBox2, ComboBox3, ComboBox4）、
コマンドボタンを２つ（cmdCancel, cmdCancel）配置します。（cmdCancel, cmdOK）

 Option Explicit
 Dim dicList(1 To 4) As Dictionary  '分類リスト格納用連想配列
 Dim CBs(1 To 4) As MSForms.ComboBox

 Private Sub cmdCancel_Click()
    Unload Me
 End Sub

 Private Sub cmdOK_Click()
    '選択したリストを使った処理
    Unload Me
 End Sub

 Public Sub SetComboBox(Idx As Long)
    If dicList(Idx).Exists(CBs(Idx).Text) Then
        Set dicList(Idx + 1) = dicList(Idx)(CBs(Idx).Text)
        If Join(dicList(Idx + 1).Keys) = "" Then
            Me.cmdOK.Enabled = True
        Else
            CBs(Idx + 1).Enabled = True
            CBs(Idx + 1).List = dicList(Idx + 1).Keys
            Dim i As Long
            For i = Idx + 1 To 4
                CBs(i).Value = ""
            Next
            For i = Idx + 2 To 4
                CBs(i).Enabled = False
            Next
            Me.cmdOK.Enabled = False
        End If
    End If
 End Sub

 Private Sub ComboBox1_Click()
    Call SetComboBox(1)
 End Sub

 Private Sub ComboBox2_Click()
    Call SetComboBox(2)
 End Sub

 Private Sub ComboBox3_Click()
    Call SetComboBox(3)
 End Sub

 Private Sub ComboBox4_Click()
    If CBs(4).Text <> "" Then Me.cmdOK.Enabled = True
 End Sub

 Private Sub UserForm_Initialize()
    Set CBs(1) = Me.ComboBox1
    Set CBs(2) = Me.ComboBox2
    Set CBs(3) = Me.ComboBox3
    Set CBs(4) = Me.ComboBox4
    CBs(2).Enabled = False
    CBs(3).Enabled = False
    CBs(4).Enabled = False
    Me.cmdOK.Enabled = False

    Dim aryData()
    With Worksheets("ListData").Range("A1").CurrentRegion
        aryData = .Offset(1).Resize(.Rows.Count - 1).Value
    End With

    Set dicList(1) = New Dictionary
    Dim i As Long
    For i = 1 To UBound(aryData)

        Call ListExistsCheck(dicList(1), dicList(2), aryData(i, 1))
        Call ListExistsCheck(dicList(2), dicList(3), aryData(i, 2))
        Call ListExistsCheck(dicList(3), dicList(4), aryData(i, 3))

        dicList(4)(CStr(aryData(i, 4))) = aryData(i, 4)
        Set dicList(3)(CStr(aryData(i, 3))) = dicList(4)
        Set dicList(2)(CStr(aryData(i, 2))) = dicList(3)
        Set dicList(1)(CStr(aryData(i, 1))) = dicList(2)
    Next

    CBs(1).List = dicList(1).Keys
 End Sub

 '子のDictionaryを取得、存在しなければ新規に生成
 Public Sub ListExistsCheck(dicListP As Dictionary, dicListC As Dictionary, key)
    If dicListP.Exists(CStr(key)) Then
        Set dicListC = dicListP(CStr(key))
    Else
        Set dicListC = New Dictionary
    End If
 End Sub

ユーザーフォームを開いた直後は「大分類」コンボのみ使用できるようになってます。
リストを選択すると次のコンボボックスが使用できるようになります。
次の分類リストがないときは、cmdOK が使用可能になります。
このクリック時に選択した分類を使った処理を記述するといいでしょう。

もし、前のコンボボックスに戻って選択しなおしたときは、
以降のコンボボックスをリセットします。

（hatena） 2021/03/06(土) 02:01

Sinking Time様
hatena様
ありがとうございます。
初心者の私ではわからない部分が多数あり、何とか調べながら理解している最中ですが、
ご提示いただいた通りに実行しただけでは

コンパイルエラー：
ユーザー定義型は定義されていません。

と表示されてしまいます。
現在、
・Visual Basic For Applications
・Microsoft Excel 15.0 Object Library
・OLE Automation
・Microsoft Office 15.0 Object Library
・Microsoft Forms 2.0 Object Library
上記5つが有効になっておりますが、追加や更新等が必要なのでしょうか？

よろしくお願いします。
（乾燥肌） 2021/03/07(日) 20:08

＞上記5つが有効になっておりますが、追加や更新等が必要なのでしょうか？
心配ご無用。一切必要ありません。ありません。
（KAN） 2021/03/07(日) 20:43

 Microsoft Scripting Runtime
参照設定だと思います。あとボタンのオブ
ジェクト名を合わせると、（hatena）さん
 2021/03/06(土) 02:01のコード
当方では動きましたですよ。(#^^#)ｖ
連想配列使いとか、纏め方が素晴らしいですね
( ..)φメモメモ
とても勉強になりました←頭のショートが
治まったような気が。。。(◎_◎;)でわでわ
m(__)m 
（隠居じーさん） 2021/03/07(日) 22:37

隠居じーさん様
ありがとうございます。
Microsoft Scripting Runtime
を有効にしたら無事動作しました。

（乾燥肌） 2021/03/08(月) 09:00

hatena様
非常に良くできているのですが、
1点不備がありまして…。

大分類　中分類　小分類　小小分類
A県
B県　　　1市
B県　　　2市　　　a区
B県　　　2市　　　b区　　　ああ
B県　　　2市　　　b区　　　いい
・　　　　・　　　・　　　　・
・　　　　・　　　・　　　　・
・　　　　・　　　・　　　　・

上のようなデータの中から
「B県 2市 b区いい」
まで選択した後、「A県」に変えた場合、
A県の中分類、小分類、小小分類リストにB県のデータが適応されたままになっています。
これはどのようにすれば対処できますでしょうか？

また、可能であれば、「クリア」というボタンを押すことで
大、中、小、小小の選択状況をリセットしたいです。

何度もお願いしてしまい申し訳ありませんが、よろしくお願いいたします。
（乾燥肌） 2021/03/08(月) 10:26

クリアボタンを押した場合に各ドロップダウンリストで選択されているものをリセットしたいのですが、
dicListをRemoveAllにてクリアした場合、何か不備が生じますでしょうか？
（乾燥肌） 2021/03/08(月) 13:18

クリアボタンを押した際の動作を以下のようにしてみました。

 Private Sub cmdクリア_Click()

 UserForm.Controls("ComboBox1") = ""
 UserForm.Controls("ComboBox2") = ""
 UserForm.Controls("ComboBox3") = ""
 UserForm.Controls("ComboBox4") = ""

 Me.ComboBox2.Enabled = False
 Me.ComboBox3.Enabled = False
 Me.ComboBox4.Enabled = False
 End Sub
（乾燥肌） 2021/03/08(月) 14:19

上位のコンボボックスを変更した際に、下位の内容をクリアするよう、自分なりに組んでみました。

 Private Sub ComboBox1_Click()
 UserForm.Controls("ComboBox2") = ""
 UserForm.Controls("ComboBox3") = ""
 UserForm.Controls("ComboBox4") = ""
 Me.ComboBox2.Enabled = False
 Me.ComboBox3.Enabled = False
 Me.ComboBox4.Enabled = False
    Call SetComboBox(1)
 End Sub

 Private Sub ComboBox2_Click()
 UserForm.Controls("ComboBox3") = ""
 UserForm.Controls("ComboBox4") = ""
 Me.ComboBox3.Enabled = False
 Me.ComboBox4.Enabled = False
    Call SetComboBox(2)
 End Sub

 Private Sub ComboBox3_Click()
 UserForm.Controls("ComboBox4") = ""
 Me.ComboBox4.Enabled = False
    Call SetComboBox(3)
 End Sub
（乾燥肌） 2021/03/08(月) 14:39

大分類　中分類　小分類　小小分類　料金
A県　　　　　　　　　　　　　　　　 1,000
B県　　　1市　　　　　　　　　　　1,200
B県　　　2市　　　a区　　　　　　　1,350
B県　　　2市　　　b区　　　ああ　　1,500
B県　　　2市　　　b区　　　いい　　1,700
・　　　　・　　　・　　　　・　　　・
・　　　　・　　　・　　　　・　　　・
・　　　　・　　　・　　　　・　　　・

上記のように、いずれのデータも「E列」に料金（数値のみ）が入力されている場合、
例えば、B県 2市 a区をコンボボックスで選択した際に「1,350」と分かるようにしたいのですが、
どのように組めばよいでしょうか？

よろしくお願いいたします。
（乾燥肌） 2021/03/08(月) 15:01

5列目の料金をテキストボックスに表示できるようにしてみました

ユーザーフォームにテキストボックス「TextBox1」を追加します。
このテキストボックスに料金を表示します。

 Option Explicit
 Dim dicList(1 To 4) As Dictionary  '分類リスト格納用連想配列
 Dim CBs(1 To 4) As MSForms.ComboBox

 Private Sub cmdCancel_Click()
    Unload Me
 End Sub

 Private Sub cmdOK_Click()
    '選択したリストを使った処理
    Unload Me
 End Sub

 Public Sub SetComboBox(Idx As Long)
    If dicList(Idx).Exists(CBs(Idx).Text) Then
        If IsObject(dicList(Idx)(CBs(Idx).Text)) Then
            Set dicList(Idx + 1) = dicList(Idx)(CBs(Idx).Text)
            CBs(Idx + 1).Enabled = True
            CBs(Idx + 1).List = dicList(Idx + 1).Keys

            Dim i As Long
            For i = Idx + 1 To 4
                CBs(i).Value = ""
            Next
            For i = Idx + 2 To 4
                CBs(i).Enabled = False
            Next
            Me.cmdOK.Enabled = False
            Me.TextBox1.Value = ""
        Else
            Me.cmdOK.Enabled = True
            Me.TextBox1.Value = dicList(Idx)(CBs(Idx).Text)
        End If
    End If
 End Sub

 Private Sub ComboBox1_Click()
    Call SetComboBox(1)
 End Sub

 Private Sub ComboBox2_Click()
    Call SetComboBox(2)
 End Sub

 Private Sub ComboBox3_Click()
    Call SetComboBox(3)
 End Sub

 Private Sub ComboBox4_Click()
    If CBs(4).Text <> "" Then
        Me.cmdOK.Enabled = True
        Me.TextBox1.Value = dicList(4)(CBs(4).Text)
    End If
 End Sub

 Private Sub UserForm_Initialize()
    Set CBs(1) = Me.ComboBox1
    Set CBs(2) = Me.ComboBox2
    Set CBs(3) = Me.ComboBox3
    Set CBs(4) = Me.ComboBox4

    CBs(2).Enabled = False
    CBs(3).Enabled = False
    CBs(4).Enabled = False
    Me.cmdOK.Enabled = False

    Dim aryData()
    With Worksheets("ListData").Range("A1").CurrentRegion
        aryData = .Offset(1).Resize(.Rows.Count - 1).Value
    End With

    Set dicList(1) = New Dictionary
    Dim i As Long
    For i = 1 To UBound(aryData)

        Call ListExistsCheck(dicList(1), dicList(2), aryData(i, 1))
        Call ListExistsCheck(dicList(2), dicList(3), aryData(i, 2))
        Call ListExistsCheck(dicList(3), dicList(4), aryData(i, 3))

        dicList(4)(CStr(aryData(i, 4))) = aryData(i, 5)
        If CStr(aryData(i, 4)) = "" Then
            Set dicList(3)(CStr(aryData(i, 3))) = aryData(i, 5)
        Else
            Set dicList(3)(CStr(aryData(i, 3))) = dicList(4)
        End If
        If CStr(aryData(i, 3)) = "" Then
            Set dicList(2)(CStr(aryData(i, 2))) = aryData(i, 5)
        Else
            Set dicList(2)(CStr(aryData(i, 2))) = dicList(3)
        End If
        If CStr(aryData(i, 2)) = "" Then
            Set dicList(1)(CStr(aryData(i, 1))) = aryData(i, 5)
        Else
           Set dicList(1)(CStr(aryData(i, 1))) = dicList(2)
        End If
    Next

    CBs(1).List = dicList(1).Keys
 End Sub

 '子のDictionaryを取得、存在しなければ新規に生成
 Public Sub ListExistsCheck(dicListP As Dictionary, dicListC As Dictionary, key)
    If dicListP.Exists(CStr(key)) Then
        Set dicListC = dicListP(CStr(key))
    Else
        Set dicListC = New Dictionary
    End If
 End Sub

以上です。

4列目のときと分類の値が""のときはDictionaryのItemに金額を代入するようにしました。
コンボボックスをクリックしたときに、対応するDictionaryのItemが
オブジェクト(Dictionary)でなければ金額と判断してテキストボックスに代入してます。

（hatena） 2021/03/08(月) 16:39

連投ご容赦。

2021/03/08(月) 10:26 の投稿で指摘されたバグの対策と、
コードを少し修正しました。

 Option Explicit
 Dim dicList(1 To 4) As Dictionary  '分類リスト格納用連想配列
 Dim CBs(1 To 4) As MSForms.ComboBox

 Private Sub cmdCancel_Click()
     Unload Me
 End Sub

 Private Sub cmdOK_Click()
     '選択したリストを使った処理
     Unload Me
 End Sub

 Public Sub SetComboBox(Idx As Long)
     If dicList(Idx).Exists(CBs(Idx).Text) Then
         Dim i As Long
         For i = Idx + 1 To 4
             CBs(i).Value = ""
         Next
         For i = Idx + 1 To 4
             CBs(i).Enabled = False
         Next
         If IsObject(dicList(Idx)(CBs(Idx).Text)) Then
             Set dicList(Idx + 1) = dicList(Idx)(CBs(Idx).Text)
             CBs(Idx + 1).Enabled = True
             CBs(Idx + 1).List = dicList(Idx + 1).Keys

             Me.cmdOK.Enabled = False
             Me.TextBox1.Value = ""
         Else
             Me.cmdOK.Enabled = True
             Me.TextBox1.Value = dicList(Idx)(CBs(Idx).Text)
         End If
     End If
 End Sub

 Private Sub ComboBox1_Click()
     Call SetComboBox(1)
 End Sub

 Private Sub ComboBox2_Click()
     Call SetComboBox(2)
 End Sub

 Private Sub ComboBox3_Click()
     Call SetComboBox(3)
 End Sub

 Private Sub ComboBox4_Click()
     If CBs(4).Text <> "" Then
         Me.cmdOK.Enabled = True
         Me.TextBox1.Value = dicList(4)(CBs(4).Text)
     End If
 End Sub

 Private Sub UserForm_Initialize()
     Set CBs(1) = Me.ComboBox1
     Set CBs(2) = Me.ComboBox2
     Set CBs(3) = Me.ComboBox3
     Set CBs(4) = Me.ComboBox4

     CBs(2).Enabled = False
     CBs(3).Enabled = False
     CBs(4).Enabled = False
     Me.cmdOK.Enabled = False

     Dim aryData()
     With Worksheets("ListData").Range("A1").CurrentRegion
         aryData = .Offset(1).Resize(.Rows.Count - 1).Value
     End With

     Set dicList(1) = New Dictionary
     Dim i As Long
     For i = 1 To UBound(aryData)
         Call ListExistsCheck(aryData, 1, i)
         Call ListExistsCheck(aryData, 2, i)
         Call ListExistsCheck(aryData, 3, i)

         dicList(4)(CStr(aryData(i, 4))) = aryData(i, 5)
         Call SetDicList(aryData, 3, i)
         Call SetDicList(aryData, 2, i)
         Call SetDicList(aryData, 1, i)
     Next

     CBs(1).List = dicList(1).Keys
 End Sub

 '子のDictionaryを取得、存在しなければ新規に生成
 Public Sub ListExistsCheck(aryData, Idx As Long, rowNum As Long)
     If dicList(Idx).Exists(CStr(aryData(rowNum, Idx))) Then
         Set dicList(Idx + 1) = dicList(Idx)(CStr(aryData(rowNum, Idx)))
     Else
         Set dicList(Idx + 1) = New Dictionary
     End If
 End Sub

 'DictionaryのItemにリストを格納、空欄の場合は金額を格納
 Public Sub SetDicList(aryData, Idx As Long, rowNum As Long)
     If CStr(aryData(rowNum, Idx + 1)) = "" Then
         Set dicList(Idx)(CStr(aryData(rowNum, Idx))) = aryData(rowNum, 5)
     Else
         Set dicList(Idx)(CStr(aryData(rowNum, Idx))) = dicList(Idx + 1)
     End If
 End Sub

（hatena） 2021/03/08(月) 17:30

hatena様
何度もありがとうございます。
ユーザーフォームにテキストボックス「TextBox1」を追加した後、早速実行してみましたが

実行時エラー'424':
オブジェクトが必要です。

と表示されてしまいました。
何が原因か分かりますでしょうか？
よろしくお願いいたします。
（乾燥肌） 2021/03/08(月) 17:36

当方のサンプルでは問題なく動作してます。

コードはそのままコピーしてますか。

エラーがでるのはどのコードででますか。

（hatena） 2021/03/08(月) 18:38

hatena様
はい、そのままコピーしています。
ここがエラーというような提示がなく、詳細が分からないのですが、

Private Sub UserForm_Initialize()

この1文の「UserForm」という部分を別の名前に変えると何故かフォームは起動しました。
例えば、「UserForm1」でもフォームは起動します。
ただ、マクロが反映されていませんでした。
原因がよくわかりません…。
（乾燥肌） 2021/03/08(月) 20:02

Private Sub UserForm_Initialize()
は変えたらダメです。

変えたらユーザーフォームを開いたときに実行されません。

「ListData」という名前のシートに分類リストの表があるのですよね。

うーん、困りましたね。
こちらでは問題なく動作しているので、
ちょっと原因は想像つかないです。

（hatena） 2021/03/08(月) 21:06

dicList(1 To 4) As Dictionary　でエラー
コンパイルエラー：
ユーザー定義型は定義されていません。
（） 2021/03/08(月) 21:35

hatena様
検索してみたら、似たようなエラーが載っていました。

https://okwave.jp/qa/q9608747.html

私はこれをみても対処法が良くわかりませんが、手掛かりになりそうでしょうか…？

（）様
私も最初そのようなエラーが出ましたが、
VBE画面の「ツール」→「参照設定」で
Microsoft Scripting Runtime
を有効にしたら解消しました。
（乾燥肌） 2021/03/08(月) 21:55

乾燥肌さん、使っているシート名は何ですか。
（bc） 2021/03/08(月) 22:08

あと、エラー発生のダイアログで「デバッグ」ボタンを押すと
黄色く反転した行のあるVBE画面になるはずです。
その黄色く反転したところがエラーの原因てす。
その行の内容について教えてください。
（bc） 2021/03/08(月) 22:13

茶々入れ失礼します。

VBEの「ツール」　「オプション」　「全般」　「エラートラップ」　で、
「クラスモジュールで中断」を選んで実行すると、
実際のエラー箇所で止まって、黄色くハイライトするはずです。

質問者さんがどこで止まったかを示すと、
解決のヒントになると思いますよ。
（γ） 2021/03/08(月) 22:19

bc様
シート名は
ListData
です。

γ様
ありがとうございます。
エラー箇所が分かりました。

'子のDictionaryを取得、存在しなければ新規に生成
という所の
Set dicList(Idx + 1) = dicList(Idx)(CStr(aryData(rowNum, Idx)))
が黄色になっています。

なお、現在
・Visual Basic For Applications
・Microsoft Excel 15.0 Object Library
・OLE Automation
・Microsoft Office 15.0 Object Library
・Microsoft Forms 2.0 Object Library
・Microsoft Scripting Runtime
上記6つが有効になっています。
よろしくお願いします。

（乾燥肌） 2021/03/08(月) 22:33

項目　　項目　　項目　　項目　　項目
大　　　中　　　小　　　　　　　100
大　　　中　　　小　　　小小　　100

こんなリストのときにエラーが出ているように思いますが合っていますか？
（bc） 2021/03/09(火) 09:02

コードを読み説くと、上記の例はListExistsCheckで

 Set dicList(Idx)(CStr(aryData(rowNum, Idx))) = aryData(rowNum, 5)

と、dicList(Idx)(CStr(aryData(rowNum, Idx)))に値を代入したあとに

 Set dicList(Idx + 1) = dicList(Idx)(CStr(aryData(rowNum, Idx)))

と、Dictionaryオブジェクトをセットしようとしてエラーになっていました。
（bc） 2021/03/09(火) 10:06

bcさん、
なるほど、そこはエラーになりますね。
サンプルのデータは同じ親分類で子分類が空欄のものは後にくるものでした。
ちょっと対策考えてみます。

（hatena） 2021/03/09(火) 13:06

思ったんですか、

項目　　項目　　項目　　項目　　項目
大　　　中　　　小　　　　　　　100
大　　　中　　　小　　　小小　　100

これってデータ的にどうなんでしょうか。

小小分類まであるということなら、小小分類に空欄はおかしいし、
小分類までなら、小小分類は空欄でないとだめなはずです。

小分類を選択した時点で、小小分類があるかどうか未確定という状態はありえるのでしょうか。

（hatena） 2021/03/09(火) 13:22

例を挙げると「医科点数表区分番号の設定例」があります。
下例では大項目のみから小小小項目までの記載区分があります。

https://shinryohoshu.mhlw.go.jp/shinryohoshu/file/info/s2code160304.pdf
（bc） 2021/03/09(火) 14:04

上記の疑問は質問者さんへのものです。
そういう事例はあるとは思いますが、
質問者さんの案件ではあるのかどうか、

大分類→中分類　で終わるものもあれば、大分類→中分類→小分類　で終わるものもあれば、
大分類→中分類→小分類→小小分類　で終わるものもあります。

という説明だと、分類を選択した時点で終わるかどうか確定しているとも取れます。

というのも、対策コードが結構面倒そうなので、
手を付ける前に確認しておきたかったのです。
（hatena） 2021/03/09(火) 14:27

すみません。
余計なことでしたね。
（bc） 2021/03/09(火) 14:38

bc様
ありがとうございます。
＞大　　　中　　　小　　　　　　　100
＞大　　　中　　　小　　　小小　　100
まさしく、上記のようになっていました。
私の操作ミスで表の一部が消えていたようです。
「医科点数表区分番号の設定例」
の例を上げていただきましたが、今回の用途ではそのようなデータは存在しません。

hatena様
ありがとうございます。
現在のコードで正しく動作しています。

もし、今後「F列」や「G列」にも現在の「E列」のように、全行データが入った場合、
同様にテキストボックスにそれらを表示させるには、どこを編集すればよいでしょうか？
（乾燥肌） 2021/03/09(火) 15:54

テキストボックスが３つありそこに表示させるということでよろしいでしょうか。

最後のDictionaryのアイテムに行番号を格納するようにして、
データ配列 aryData() はモジュールレベルで宣言して、
テキストボックスに代入するときは、行番号を元にaryData()から値を取得するようにしてみました。

 Option Explicit
 Dim dicList(1 To 4) As Dictionary  '分類リスト格納用連想配列
 Dim CBs(1 To 4) As MSForms.ComboBox
 Dim aryData()

 Private Sub cmdCancel_Click()
     Unload Me
 End Sub
 Private Sub cmdOK_Click()
     '選択したリストを使った処理
     Unload Me
 End Sub
 Public Sub SetComboBox(Idx As Long)
     If dicList(Idx).Exists(CBs(Idx).Text) Then
         Dim i As Long
         For i = Idx + 1 To 4
             CBs(i).Value = ""
         Next
         For i = Idx + 1 To 4
             CBs(i).Enabled = False
         Next
         If IsObject(dicList(Idx)(CBs(Idx).Text)) Then
             Set dicList(Idx + 1) = dicList(Idx)(CBs(Idx).Text)
             CBs(Idx + 1).Enabled = True
             CBs(Idx + 1).List = dicList(Idx + 1).Keys
             Me.cmdOK.Enabled = False
             Me.TextBox1.Value = ""
             Me.TextBox2.Value = ""
             Me.TextBox3.Value = ""
         Else
             Me.cmdOK.Enabled = True
             Dim r As Long: r = dicList(Idx)(CBs(Idx).Text)
             Me.TextBox1.Value = aryData(r, 5)
             Me.TextBox2.Value = aryData(r, 6)
             Me.TextBox3.Value = aryData(r, 7)
         End If
     End If
 End Sub
 Private Sub ComboBox1_Click()
     Call SetComboBox(1)
 End Sub
 Private Sub ComboBox2_Click()
     Call SetComboBox(2)
 End Sub
 Private Sub ComboBox3_Click()
     Call SetComboBox(3)
 End Sub
 Private Sub ComboBox4_Click()
     If CBs(4).Text <> "" Then
         Me.cmdOK.Enabled = True
         Dim r As Long: r = dicList(4)(CBs(4).Text)
         Me.TextBox1.Value = aryData(r, 5)
         Me.TextBox2.Value = aryData(r, 6)
         Me.TextBox3.Value = aryData(r, 7)
     End If
 End Sub
 Private Sub UserForm_Initialize()
     Set CBs(1) = Me.ComboBox1
     Set CBs(2) = Me.ComboBox2
     Set CBs(3) = Me.ComboBox3
     Set CBs(4) = Me.ComboBox4
     CBs(2).Enabled = False
     CBs(3).Enabled = False
     CBs(4).Enabled = False
     Me.cmdOK.Enabled = False

     With Worksheets("ListData").Range("A1").CurrentRegion
         aryData = .Offset(1).Resize(.Rows.Count - 1).Value
     End With
     Set dicList(1) = New Dictionary
     Dim i As Long
     For i = 1 To UBound(aryData)
         Call ListExistsCheck(aryData, 1, i)
         Call ListExistsCheck(aryData, 2, i)
         Call ListExistsCheck(aryData, 3, i)
         dicList(4)(CStr(aryData(i, 4))) = i
         Call SetDicList(aryData, 3, i)
         Call SetDicList(aryData, 2, i)
         Call SetDicList(aryData, 1, i)
     Next
     CBs(1).List = dicList(1).Keys
 End Sub
 '子のDictionaryを取得、存在しなければ新規に生成
 Public Sub ListExistsCheck(aryData, Idx As Long, rowNum As Long)
     If dicList(Idx).Exists(CStr(aryData(rowNum, Idx))) Then
         Set dicList(Idx + 1) = dicList(Idx)(CStr(aryData(rowNum, Idx)))
     Else
         Set dicList(Idx + 1) = New Dictionary
     End If
 End Sub
 'DictionaryのItemにリストを格納、空欄の場合は金額を格納
 Public Sub SetDicList(aryData, Idx As Long, rowNum As Long)
     If CStr(aryData(rowNum, Idx + 1)) = "" Then
         dicList(Idx)(CStr(aryData(rowNum, Idx))) = rowNum
     Else
         Set dicList(Idx)(CStr(aryData(rowNum, Idx))) = dicList(Idx + 1)
     End If
 End Sub

（hatena） 2021/03/09(火) 17:00

hatena様
ありがとうございます。
素晴らしいです。完璧です！

この件に携わっていただいた皆様方、本当にありがとうございました。
（乾燥肌） 2021/03/09(火) 19:23

コメント返信：

[ 一覧(最新更新順) ]

[[20210302204123]] 『ドロップダウンリストをVBAで』（乾燥肌） ページの最後に飛ぶ

[[20210302204123]]　『ドロップダウンリストをVBAで』（乾燥肌）　ページの最後に飛ぶ