[[20180609095822]]　『リストボックスの３連以上の連携』（らる）　ページの最後に飛ぶ

『リストボックスの３連以上の連携』（らる）

別シートにＡセルは都道府県名、Ｂセルには市区名、Ｃセルには区町名
と言ったようにリストを用意します
リストボックスを３つ用意し、リストボックス１は都道府県選択、それに応じリストボックス市区２のリストが変動、次のリストボックス３も変わると言ったことがしたいのです
ただし、Additemでソース上に記入するやり方はできます、ただソースコードが長くなってしまい、見づらくなります
できれば、RowSourceで簡単に記入していきたいのですが、いまいちわからないです
因みに、ここのサイトのコンボボックスのやり方を参考にしてみましたが、３つ目の分岐がうまくいきません
リストボックス２分岐条件でのcase の後ろに"○○市"のようにソースコードを記入するとエラーが出ます、また数字にすると３つ目は変化しないといったようなことになってしまいます
解決策がわかりません、よろしくおねがいします

＜使用 Excel：Excel2007、使用 OS：Windows8 ＞

今のコードを提示してみては？
# フィルタオプションかなにかを併用すると良い気はしますが。

（γ） 2018/06/09(土) 10:44

別シートの表はＡ列にリストボックス１の内容
Ｃ，Ｄ，Ｅ列にはリストボックス２に入るＡ列に対応する内容を
Ｇ列以降にはリストボックス３に入る内容を作っておいてます

コードは以下の通り
Private Sub ListBox1_Change()

    Dim sa As Integer

    With UserForm1

        .ListBox2.Text = ""

        sa = .ListBox1.ListIndex

        Select Case sa

        Case 0

        .ListBox2.RowSource = "sheet1!c1:c6"

         Case 1

        .ListBox2.RowSource = "sheet1!d1:d6"

        Case 2

        .ListBox2.RowSource = "sheet1!e1:e6"

        End Select

    End With

End Sub

Private Sub ListBox2_Change()

    Dim sb As Integer

    With UserForm1

        .ListBox3.Text = ""
        sb = .ListBox2.ListIndex
        Select Case sb

            Case バインダー
                .ListBox3.RowSource = "sheet1!g1:g6"

            Case 色鉛筆
                .ListBox3.RowSource = "sheet1!h1:h6"

            Case 筆箱
                .ListBox3.RowSource = "sheet1!i1:i6"

            Case ボールペン
                .ListBox3.RowSource = "sheet1!j1:j6"

            Case 文庫
                .ListBox3.RowSource = "sheet1!l1:l6"

            Case 専門書
                .ListBox3.RowSource = "sheet1!m1:m6"

            Case 図鑑
                .ListBox3.RowSource = "sheet1!n1:n6"

            Case マウス
                .ListBox3.RowSource = "sheet1!p1:p6"

            Case ディスプレー
                .ListBox3.RowSource = "sheet1!q1:q6"

            Case PC
                .ListBox3.RowSource = "sheet1!r1:r6"

            Case USBメモリー
                .ListBox3.RowSource = "sheet1!s1:s6"

            Case キーボード
                .ListBox3.RowSource = "sheet1!t1:t6"

            Case 5
                .ListBox3.RowSource = "sheet1!u1:u6"

            End Select

        End With
End Sub

Private Sub UserForm_Activate()

    With UserForm1

        .ListBox1.RowSource = "sheet1!a1:a6"
        .ListBox2.RowSource = "sheet1!c1:c6"
        .ListBox3.RowSource = "sheet1!l1:l6"
    End With
End Sub

Private Sub UserForm_Click()

End Sub

です
これはあくまで、テストようであって本チャンは別に作る予定です
（らる） 2018/06/09(土) 12:38

 質問者さんの今の方式でよいと思いました。
 ListBox2_ChangeのなかでListIndexを使っていますが、
 それはValueの間違いなんだろうと思いますが。

 それとは別に、こんな方法を考えてみました。
 ># フィルタオプションかなにかを併用すると良い気はしますが。 
 などと書きましたので責任をとって、コードを書いて見ました。

 データは以下のようなものとして、
 これをもとに自動的に重複を除いたコードを抽出します。

 使用しているコントロールは、以下の4つです。
 ・CommandButton1
 ・ListBox1    「地域」表示用
 ・ListBox2    「区」　表示用
 ・ListBox3    「町」  表示用

 ・CommandButton1を押すことで、
   ListBox1に地域の3種類（東京都、横浜市、名古屋市）を表示
 ・ListBox1のいずれかを選択することで、これに対応する区の選択肢をListBox2に表示します。
 ・以下同じ。

 <<Sheet1>> ==================================================
       A         B           C     D     E         F     G
 1                                       地域      区    町
 2     地域      区          町          
 3     東京都    品川区      A                       
 4     東京都    品川区      B                       
 5     東京都    大田区      C                       
 6     東京都    大田区      D                       
 7     東京都    港区        E                       
 8     東京都    港区        F                       
 9     横浜市    中区        G                       
 10    横浜市    中区        H                       
 11    横浜市    保土ヶ谷区  I                       
 12    横浜市    保土ヶ谷区  J                       
 13    横浜市    西区        K                       
 14    横浜市    西区        L                       
 15    名古屋市  南区        M                       
 16    名古屋市  南区        N                       
 17    名古屋市  中村区      O                       
 18    名古屋市  中村区      P                       
 19    名古屋市  瑞穂区      Q

 細かい説明はコードをご覧下さい。

 Option Explicit

 Dim ws       As Worksheet
 Dim target   As Range
 Dim body     As Range
 Dim criteria As Range

 Dim skipflag As Boolean
 ' ============================
 Private Sub UserForm_Initialize()
     Set ws = Worksheets("Sheet1")

     Set target = ws.Range("A2").CurrentRegion      'フィルタオプションの範囲
     Set body = Intersect(target, target.Offset(1)) '見出しを除く本体部分
     Set criteria = ws.Range("E1:G2")    '検索条件範囲（見出しと値両方が必要）

     Application.ScreenUpdating = False

     skipflag = False
 End Sub
 ' ============================
 Private Sub CommandButton1_Click()
     Dim r As Range

     With ws
         On Error Resume Next
         .ShowAllData
         On Error GoTo 0

         'フィルタオプションの検索条件の値を初期化
         criteria.Rows(2).ClearContents

         '最初のアイテムを対象に、重複を無視して抽出
         target.Resize(, 1).AdvancedFilter Action:=xlFilterInPlace, _
                 CriteriaRange:=criteria.Resize(, 1), Unique:=True

         '初期化
         skipflag = True     'changeの動作をスキップするため
         ListBox1.Clear
         skipflag = False

         '結果をListBox1に設定
         For Each r In body.Columns(1).SpecialCells(xlCellTypeVisible)
             ListBox1.AddItem r.Value
         Next
     End With
 End Sub
 ' ============================
 Private Sub ListBox1_Change()
     Dim r As Range

     If skipflag Then Exit Sub

     With ws
         On Error Resume Next
         .ShowAllData
         On Error GoTo 0

         criteria.Cells(2, 1).Value = ListBox1.Value
         criteria.Cells(2, 2).Resize(1, 2).ClearContents

         target.Resize(, 2).AdvancedFilter Action:=xlFilterInPlace, _
                 CriteriaRange:=criteria.Resize(, 1), Unique:=True

         skipflag = True
         ListBox2.Clear
         ListBox3.Clear
         skipflag = False

         For Each r In body.Columns(2).SpecialCells(xlCellTypeVisible)
             ListBox2.AddItem r.Value
         Next
     End With
 End Sub
 ' ============================
 Private Sub ListBox2_Change()
     Dim r As Range

     If skipflag Then Exit Sub

     With ws
         On Error Resume Next
         .ShowAllData
         On Error GoTo 0

         criteria.Cells(2, 1).Value = ListBox1.Value
         criteria.Cells(2, 2).Value = ListBox2.Value

         target.AdvancedFilter Action:=xlFilterInPlace, _
                 CriteriaRange:=criteria.Resize(, 2), Unique:=True

         skipflag = True
         ListBox3.Clear
         skipflag = False

         For Each r In body.Columns(3).SpecialCells(xlCellTypeVisible)
             ListBox3.AddItem r.Value
         Next
     End With
 End Sub

 なにかゴテゴテしている感じかもしれません。ほんのご参考まで。

（γ） 2018/06/10(日) 08:27

今回の質問はVBAのようですので、向いてないのかもですが「都道府県」を選択したら「市町村」の候補が連騰して変化・・というのは、入力規則でも可能です。

http://liginc.co.jp/177947
https://excel-hack.com/beginner/pulldown-menu-interlock/

興味があれば研究してみるのもいいかもです。

（もこな２） 2018/06/10(日) 08:43

γさんのアイデア及びコードを少しいじってみました。（改悪？）
手作業で事前準備することで、
コード自体は多少コンパクトにできるかもしれません。

いずれにしてもフィルタオプションに使い慣れていないと
何をしているか理解しにくいかも。

 １）シート構成は、γさんと同じでよいです
 実際は、H～J列を作業列として使い
 リスト作成用のデータを抽出しています。

 ２）CommandButton1は使いませんでした。

 ３）事前に名前定義（自動でデータ範囲を取得しています）
  field1：=OFFSET(Sheet1!$H$2,0,0,COUNTA(Sheet1!$H:$H),1)
  field2：=OFFSET(Sheet1!$I$2,0,0,COUNTA(Sheet1!$I:$I),1)
  field3：=OFFSET(Sheet1!$J$2,0,0,COUNTA(Sheet1!$J:$J),1)

 Option Explicit

 Dim ws       As Worksheet
 Dim target   As Range
 Dim criteria As Range
 Dim extract  As Range
 Dim skipflag As Boolean

 ' ============================
 Private Sub UserForm_Initialize()
     Set ws = Worksheets("Sheet1")
     Set target = ws.Range("A2").CurrentRegion      'フィルタオプションの範囲
     Set criteria = ws.Range("E1:F2")    '検索条件範囲（見出しと値両方が必要）
     Set extract = ws.Range("H1:J1")    '抽出範囲（リスト作成の作業列）
     Dim r As Range

     With ws
         'フィルタオプションの検索条件の値を初期化
         criteria.Rows(2).ClearContents

         '初期化
         skipflag = True     'changeの動作をスキップするため        
         '最初のアイテムを対象に、重複を無視して抽出
         target.Rows(1).Copy extract
         target.AdvancedFilter Action:=xlFilterCopy, _
                 CriteriaRange:=criteria, CopyToRange:=extract.Cells(1, 1), Unique:=True
        ListBox1.RowSource = "field1"
        ListBox2.RowSource = ""
        ListBox3.RowSource = ""      
         skipflag = False

     End With

 End Sub

 ' ============================
 Private Sub ListBox1_Change()
    Dim r As Range

    If skipflag Then Exit Sub

    With ws
        criteria.Cells(2, 1).Value = ListBox1.Value
        criteria.Cells(2, 2).ClearContents

        skipflag = True     
        target.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=criteria, CopyToRange:=extract.Cells(1, 2), Unique:=True 
        ListBox2.RowSource = "field2"
        ListBox2.ListIndex = -1
        ListBox3.RowSource = ""
        skipflag = False

    End With

 End Sub

 '  ============================
 Private Sub ListBox2_Change()
    Dim r As Range

    If skipflag Then Exit Sub

    With ws
        criteria.Cells(2, 2).Value = ListBox2.Value

        skipflag = True  
        target.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=criteria, CopyToRange:=extract.Cells(1, 3), Unique:=True   
        ListBox3.RowSource = "field3"
        skipflag = False

    End With

 End Sub

（マナ） 2018/06/10(日) 15:13

私もちょっと考えてみました。

別シートの表はＡ列にリストボックス１の内容Ｃ，Ｄ，Ｅ列にはリストボックス２に入るＡ列に対応する内容をＧ列以降にはリストボックス３に入る内容を作っておいてます

データの持ち方は、質問者さんの上記の方法に、ちょっとアレンジを加えて、

<<Sheet1>> ==========================================

     A         B    C        D        E        F    G         H
 1   リスト1        あああ   いいい   ううう        あああ1   あああ2
 2   あああ         あああ1  いいい1  ううう1       あああ11  あああ21
 3   いいい         あああ2  いいい2  ううう2       あああ12  あああ22
 4   ううう         あああ3  いいい3  ううう3       あああ13  あああ23
 5                  あああ4  いいい4  ううう4       あああ14  あああ24
 6                  あああ5  いいい5  ううう5       あああ15  あああ25
 7                  あああ6  いいい6  ううう6       あああ16  あああ26

A列の２行目からリストボックス1のリストデータ
Ｃ，Ｄ，Ｅ列にはリストボックス２に入るリストデータですが、１行目はA列の内容を縦横変換して
貼り付けしておきます。データは２行目からです。

G列以降はリストボックス３のリストデータですが、同じく１行目はリストボックス2のデータです。

こういう形式にしておけば、データ内容をチェックするときも見やすいでしょう。

Private Sub ListBox1_AfterUpdate()

    Dim r As Range
    Me.ListBox2.ListIndex = -1
    With Worksheets("Sheet1")
        Set r = .Range("C1").CurrentRegion.Rows(1).Find(What:=Me.ListBox1.Value)
        Set r = .Range(r.Offset(1), r.End(xlDown))
        Me.ListBox2.RowSource = "Sheet1!" & r.Address
    End With
    Me.ListBox3.RowSource = ""
End Sub

Private Sub ListBox2_AfterUpdate()

    Dim r As Range
    Me.ListBox3.ListIndex = -1
    With Worksheets("Sheet1")
        Set r = .Range("G1").CurrentRegion.Rows(1).Find(What:=Me.ListBox2.Value)
        Set r = .Range(r.Offset(1), r.End(xlDown))
        Me.ListBox3.RowSource = "Sheet1!" & r.Address
    End With
End Sub

（hatena） 2018/06/10(日) 15:44

データの持ち方は前の回答と同じで、RowSource に設定するセル範囲に名前を定義してみました。
コードがさらにシンプルになり、かつデータを追加、削除してもコードを変更する必要はありません。

Private Sub ListBox1_AfterUpdate()

    Me.ListBox2.ListIndex = -1
    Me.ListBox2.RowSource = Me.ListBox1.Value
    Me.ListBox3.RowSource = ""
End Sub

Private Sub ListBox2_AfterUpdate()

    Me.ListBox3.ListIndex = -1
    Me.ListBox3.RowSource = Me.ListBox2.Value
End Sub

Private Sub UserForm_Initialize()

    Dim r As Range, i As Long
    Dim n As Name

    '定義された名前をすべて削除
    For Each n In Names
        n.Delete
    Next

    With Worksheets("Sheet1")
        'すべてのリストデータに１行目の値を名前として定義する。
        For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
            Set r = .Cells(1, i)
            If r.Value <> "" Then
                r.Offset(1).Resize(r.End(xlDown).Row - 1).Name = r.Value
            End If
        Next

        Me.ListBox1.RowSource = .Cells(1, 1).Value
    End With
End Sub

（hatena） 2018/06/10(日) 16:40

マナさんコード提供ありがとうございました。
参考にさせていただきます。
　
私の出発点は、
「提示した表を加工せず、自動で（しかも毎回！）リストボックスの要素を
抽出すること」にありましたので、フィルタオプションに淫したものになってしまいました。
加えて、当初のコードが間違った抽出（重複あり）の結果を返したものですから、
そのバグつぶしにヤッキになっていました（Clearに伴う再入処理のせいでした）。
　
したがいまして、質問者さんは私のものはうっちゃってくださいね。
（私の回答の際、冒頭にそれらしき雰囲気のことを書いているはずです。）
　
他の皆様からの適切な回答に注力してください。

（γ） 2018/06/10(日) 20:04

使ってない変数とかおかしなことろがあったので修正しました。

 Option Explicit

 Dim target   As Range
 Dim criteria As Range
 Dim extract  As Range
 Dim skipflag As Boolean

 ' ============================
 Private Sub UserForm_Initialize()
    Dim ws As Worksheet

     Set ws = Worksheets("Sheet1")
     Set target = ws.Range("A2").CurrentRegion      'フィルタオプションの範囲
     Set criteria = ws.Range("E1:F2")    '検索条件範囲（見出しと値両方が必要）
     Set extract = ws.Range("H1:J1")    '抽出範囲（リスト作成の作業列）

    'フィルタオプションの検索条件の値を初期化
    criteria.Rows(2).ClearContents

    '初期化
    skipflag = True     'changeの動作をスキップするため
    '最初のアイテムを対象に、重複を無視して抽出
    target.Rows(1).Copy extract
    target.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=criteria, CopyToRange:=extract.Cells(1, 1), Unique:=True

    ListBox1.RowSource = "field1"
    ListBox2.RowSource = ""
    ListBox3.RowSource = ""
    skipflag = False

 End Sub

 ' ============================
 Private Sub ListBox1_Change()

    If skipflag Then Exit Sub

        criteria.Cells(2, 1).Value = ListBox1.Value
        criteria.Cells(2, 2).ClearContents

        skipflag = True
        target.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=criteria, CopyToRange:=extract.Cells(1, 2), Unique:=True
        ListBox2.RowSource = "field2"
        ListBox2.ListIndex = -1
        ListBox3.RowSource = ""
        skipflag = False

 End Sub

 '  ============================
 Private Sub ListBox2_Change()

    If skipflag Then Exit Sub

    criteria.Cells(2, 2).Value = ListBox2.Value

    target.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=criteria, CopyToRange:=extract.Cells(1, 3), Unique:=True
    ListBox3.RowSource = "field3"

 End Sub

（マナ） 2018/06/10(日) 23:08

前回の回答のコードで、名前定義をすべて削除していましたが、他のシートでも名前定義を使用している場合、それも削除してしまうので、リストデータのあるシート上だけ削除するように修正しました。
また、名前の設定を CreateNamesメソッドを使用する方法に変更しました。（そのほうが若干シンプルになる）

Private Sub ListBox1_AfterUpdate()

    Me.ListBox2.ListIndex = -1
    Me.ListBox2.RowSource = Me.ListBox1.Value
    Me.ListBox3.RowSource = ""
End Sub

Private Sub ListBox2_AfterUpdate()

    Me.ListBox3.ListIndex = -1
    Me.ListBox3.RowSource = Me.ListBox2.Value
End Sub

Private Sub UserForm_Initialize()

    Dim r As Range, i As Long
    Dim n As Name

    'Sheet1上の定義された名前をすべて削除
    For Each n In Names
        If n.RefersToRange.Parent.Name = "Sheet1" Then n.Delete
    Next

    With Worksheets("Sheet1")
        'すべてのリストデータに１行目の値を名前として定義する。
        For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
            Set r = .Cells(1, i)
            If r.Value <> "" Then
                'r.Offset(1).Resize(r.End(xlDown).Row - 1).Name = r.Value
                r.Resize(r.End(xlDown).Row).CreateNames Top:=True
            End If
        Next

        Me.ListBox1.RowSource = .Cells(1, 1).Value
    End With
End Sub

（hatena） 2018/06/11(月) 11:33

データの形が最初の質問のようにA列、B列、C列の３列に並んでいる場合のコードも考えてみました。
この場合、まず重複の排除をどうするかですね。
AdvancedFilter を使用する方法は、γさん、マナさんからすでに回答がありますので、
Dictionaryオブジェクトを使う方法でやってみました。

２行目に項目名、３行目からデータがあるとします。

Option Explicit
Dim Dic As New Dictionary

Private Sub ListBox1_AfterUpdate()

    Me.ListBox2.ListIndex = -1
    Me.ListBox2.List = Dic(Me.ListBox1.Value).Keys
    Me.ListBox3.Clear
End Sub

Private Sub ListBox2_AfterUpdate()

    Me.ListBox3.ListIndex = -1
    Me.ListBox3.List = Split(Trim(Dic(Me.ListBox1.Value)(Me.ListBox2.Value)))
End Sub

Private Sub UserForm_Initialize()

    Dim rng As Range, v() As Variant, buf As String
    Dim r As Long

    With Worksheets("Sheet2")
        v = .Range("A2").CurrentRegion.Value
        For r = 2 To UBound(v)
            buf = v(r, 1)
            If Not Dic.Exists(buf) Then
                Dic.Add buf, New Dictionary
                Dic(buf)(v(r, 2)) = v(r, 3)
            Else
                Dic(buf)(v(r, 2)) = Dic(buf)(v(r, 2)) & " " & v(r, 3)
            End If
        Next
    End With
    Me.ListBox1.List = Dic.Keys
End Sub

Private Sub UserForm_Terminate()

    Dim i, dic2 As Dictionary

    For Each i In Dic.Items
        i.RemoveAll
    Next
    Dic.RemoveAll
End Sub

解説

リストボックス1のデータは、Dic(Dictionaryオブジェクト）のKeyに格納します。
さらにDicのItem毎にDictionaryオブジェクトを生成して、
そのKeyにリストボックス2のデータを格納し、
Itemにはリストボックス３のデータを空白区切りの文字列として格納します。

リストボックスのリストにセットするのは、
リストボックス1は、Dic.Keys で配列として取り出せるので、
Listプロパティに代入します。
リストボックス2は、Dic(Me.ListBox1.Value).Keys で配列として取り出して、
Listプロパティに代入します。
リストボックス2は、Dic(Me.ListBox1.Value)(Me.ListBox2.Value) で
空白区切りの文字列として取り出せるので、Split で配列に変換して、
Listプロパティに代入します。
（hatena） 2018/06/11(月) 13:55

コメント返信：

[ 一覧(最新更新順) ]

[[20180609095822]] 『リストボックスの３連以上の連携』（らる） ページの最後に飛ぶ

[[20180609095822]]　『リストボックスの３連以上の連携』（らる）　ページの最後に飛ぶ