[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『リストボックスの3連以上の連携』(らる)
別シートにAセルは都道府県名、Bセルには市区名、Cセルには区町名
と言ったようにリストを用意します
リストボックスを3つ用意し、リストボックス1は都道府県選択、それに応じリストボックス市区2のリストが変動、次のリストボックス3も変わると言ったことがしたいのです
ただし、Additemでソース上に記入するやり方はできます、ただソースコードが長くなってしまい、見づらくなります
できれば、RowSourceで簡単に記入していきたいのですが、いまいちわからないです
因みに、ここのサイトのコンボボックスのやり方を参考にしてみましたが、3つ目の分岐がうまくいきません
リストボックス2分岐条件でのcase の後ろに"○○市"のようにソースコードを記入するとエラーが出ます、また数字にすると3つ目は変化しないといったようなことになってしまいます
解決策がわかりません、よろしくおねがいします
< 使用 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
http://liginc.co.jp/177947
https://excel-hack.com/beginner/pulldown-menu-interlock/
興味があれば研究してみるのもいいかもです。
(もこな2) 2018/06/10(日) 08:43
いずれにしてもフィルタオプションに使い慣れていないと
何をしているか理解しにくいかも。
1)シート構成は、γさんと同じでよいです 実際は、H〜J列を作業列として使い リスト作成用のデータを抽出しています。
2)CommandButton1は使いませんでした。
3)事前に名前定義(自動でデータ範囲を取得しています) 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
別シートの表はA列にリストボックス1の内容 C,D,E列にはリストボックス2に入るA列に対応する内容を G列以降にはリストボックス3に入る内容を作っておいてます
データの持ち方は、質問者さんの上記の方法に、ちょっとアレンジを加えて、
<<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列の2行目からリストボックス1のリストデータ
C,D,E列にはリストボックス2に入るリストデータですが、1行目はA列の内容を縦横変換して
貼り付けしておきます。データは2行目からです。
G列以降はリストボックス3のリストデータですが、同じく1行目はリストボックス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
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") 'すべてのリストデータに1行目の値を名前として定義する。 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
(γ) 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
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") 'すべてのリストデータに1行目の値を名前として定義する。 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
2行目に項目名、3行目からデータがあるとします。
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にはリストボックス3のデータを空白区切りの文字列として格納します。
リストボックスのリストにセットするのは、
リストボックス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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.