VBA コンボボックス リスト表示について

質問

初心者ですいません
エクセル　VBAのフォームでコンボボックス３つと、テキストボックス３つがあります
シートのListにA～Ｆ列までのデータがあり、コンボボックス１にA列のリストを表示し
コンボボックス２にA列で選んだリストを参照したB列のリストを表示し、コンボボックス３
にコンボボックス１，２で選んだリストを参照し、C列のリストを表示した後、
コンボボックス１，２，３で選ばれたもののD列、E列分をテキストボックス１，２に
反映しようと思っておりますがうまくいきません
どのようにしたらよいか、おしえてください
宜しくお願いします
ちなみに、リストの内容は
Ａ列　　　Ｂ列　　　C列　　　　　Ｄ列　　　Ｅ列
テレビ　42インチ　　HDD内蔵　　台　　　　100,000
テレビ　32インチ　　BD内蔵　　　台　　　　　80,000
テレビ　19インチ　　　　　　　　　 台　　　　　50,000
ビデオ　HDD　　　１TB　　　　　台　　　　100,000　　
ビデオ　HDD　　　500GB　　　 台　　　　　80,000
ビデオ　BD　　　　　　　　　　　 台　　　　　70,000
が、入ってます
希望は、質問の際のカテゴリ選択のようになればよいのですが．．．
さらに、希望を言えば、自動で、行ごとに1,2,3...と番号を振るようにしており
スピンボタンで番号を選べば、登録された上記のデータをフォームに反映させるようにしております
これもうまくいきません
お願いばかりで申し訳ありませんが
宜しくお願いします

回答No.2

mitarashi · ベストアンサー

コンボボックスによる複数段の絞り込みについて検索してみると次の二方法がみつかります。
方法１：コンボボックスが変化する度に、データをスキャンして、条件に合うものを選び出す。
方法２：裏でオートフィルタまたはフィルタオプションを使い、順次絞り込む。

方法２はやってみた事があるのですが、第３の方法を考えてみました。RangeのCollectionを用いて、条件に合うRangeに絞っていく、方法２をメモリ上で行うような方法です。動いたのですが、いかにもコードが長いため、正統的な方法１によるコードはどの位になるのか試しにやってみました。コードは結構短いですね。
当方xl2000です。この方法は、元データが巨大になると遅いと思います。
Dim targetRange As Range

Private Sub UserForm_Initialize()
Dim i As Long
Dim keyList1 As New Collection

Set targetRange = Sheets("Sheet1").Range("A1").CurrentRegion
'下記行は見出し行カットです。一行目が見出しでなければ、コメントにしてください。
Set targetRange = Intersect(targetRange, targetRange.Offset(1, 0))
With targetRange
For i = 1 To .Rows.Count
On Error Resume Next
keyList1.Add CStr(.Cells(i, 1).Value), CStr(.Cells(i, 1).Value)
If Err.Number = 0 Then ComboBox1.AddItem CStr(.Cells(i, 1).Value)
Next i
End With
End Sub

Private Sub ComboBox1_Change()
Dim keylist2 As New Collection
Dim i As Long, counter As Long

If ComboBox1.Value = "" Then Exit Sub
With targetRange
For i = 1 To .Rows.Count
On Error Resume Next
If CStr(.Cells(i, 1).Value) = ComboBox1.Value Then
keylist2.Add CStr(.Cells(i, 2).Value), CStr(.Cells(i, 2).Value)
If Err.Number = 0 Then ComboBox2.AddItem CStr(.Cells(i, 2).Value)
End If
Next i
End With
End Sub

Private Sub ComboBox2_Change()
Dim keylist3 As New Collection
Dim i As Long, counter As Long

If Me.ComboBox2.Value = "" Then Exit Sub
With targetRange
For i = 1 To .Rows.Count
On Error Resume Next
If CStr(.Cells(i, 1).Value) = ComboBox1.Value And CStr(.Cells(i, 2).Value) = ComboBox2.Value Then
keylist3.Add CStr(.Cells(i, 3).Value), CStr(.Cells(i, 3).Value)
If Err.Number = 0 Then ComboBox3.AddItem CStr(.Cells(i, 3).Value)
End If
Next i
End With
If ComboBox3.ListCount = 1 Then
ComboBox3.Value = ComboBox3.List(0)
Call ComboBox3_Change
End If
End Sub

Private Sub ComboBox3_Change()
Dim i As Long

With targetRange
For i = 1 To .Rows.Count
If CStr(.Cells(i, 1).Value) = ComboBox1.Value And CStr(.Cells(i, 2).Value) = ComboBox2.Value And _
CStr(.Cells(i, 3).Value) = ComboBox3.Value Then
TextBox1.Value = CStr(.Cells(i, 4).Value)
TextBox2.Value = CStr(.Cells(i, 5).Value)
Exit For
End If
Next i
End With
End Sub

お礼

ご連絡が遅くなり申し訳ありません
大変、参考になりました
ありがとうございました

無理を言いますと、
オプションボタンが３つありまして、どれかを選ぶと
TextBox３には、F列、G列、H列を選ぶようにしたいのですが
どのようにしたらよいですか？
オプションボタン１にチェックを入れるとF列を反映し、２にチェックを入れると
G列を反映、３にチェックを入れるとF列を反映するようにしたいです

申し訳ありませんが、宜しくお願いします

回答No.7

piroin654

No6でNo3、No4としていましたが、
No4とNo5の間違いです。

回答No.6

piroin654

No3、No4です。

No3のところで場合によってはComboBox1の
初期化が必要になるかもしれないので、

Private Sub ComboBox1_Enter()

のところで、

Me!ComboBox1.Clear
Set dic = CreateObject("Scripting.Dictionary")

のように、

Me!ComboBox1.Clear

を追加しておいてください。

回答No.5

piroin654

【回答その2】スピンボタン

テキストボックスtextBox4～TextBox9を用意し、以下のように
設定します。TextBox9はカウンタ用なのでスピンボタンの
そばに置いてください。

Private Sub UserForm_Initialize()
Me!TextBox9.Value = 0
End Sub

Private Sub SpinButton1_SpinDown()
Dim i As Long

Me!TextBox9.Value = Me!TextBox9.Value + 1
For i = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
If CStr(Cells(i, "G")) = CStr(Me!TextBox9.Value) Then
Me!TextBox4.Value = Sheets("Sheet1").Cells(i, "A")
Me!TextBox5.Value = Sheets("Sheet1").Cells(i, "B")
Me!TextBox6.Value = Sheets("Sheet1").Cells(i, "C")
Me!TextBox7.Value = Sheets("Sheet1").Cells(i, "D")
Me!TextBox8.Value = Sheets("Sheet1").Cells(i, "E")
Exit For
End If
Next i
End Sub

Private Sub SpinButton1_SpinUp()
Dim i As Long

Me!TextBox9.Value = Me!TextBox9.Value - 1
For i = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
If CStr(Cells(i, "G")) = CStr(Me!TextBox9.Value) Then
Me!TextBox4.Value = Sheets("Sheet1").Cells(i, "A")
Me!TextBox5.Value = Sheets("Sheet1").Cells(i, "B")
Me!TextBox6.Value = Sheets("Sheet1").Cells(i, "C")
Me!TextBox7.Value = Sheets("Sheet1").Cells(i, "D")
Me!TextBox8.Value = Sheets("Sheet1").Cells(i, "E")
Exit For
End If
Next i
End Sub

回答No.4

piroin654

回答を二つに分けます。

【回答その1】
コンボボックスの設定ですが、一つ問題があります。
質問の場合のデータで、もし以下のようなデータがあると
したら、テキストボックスにはどちらかのデータしか
入りません。あるいはいくつもあれば適当なデータが入ります。
このような場合はどのような対応をとるのですか。
以下ではテレビとビデオにＡ列からD列まではデータが
同じで、E列のみデータが違うものが存在するとしています。

Ａ列　　　Ｂ列　　　C列　　　　　Ｄ列　　　Ｅ列
テレビ　42インチ　　HDD内蔵　　　台　　　　100,000
テレビ　32インチ　　BD内蔵　　　　台　　　　80,000
テレビ　19インチ　　　　　　　　　 台　　　50,000
テレビ　42インチ HDD内蔵　　　台　　　　150,000
ビデオ　HDD　　　　１TB　　　　　台　　　　100,000　　
ビデオ　HDD　　　　500GB　　　　台　　　　　80,000
ビデオ　BD　　　　　　　　　　　 台　　　　　70,00
ビデオ　HDD　　　　500GB　　　　　台　　　　100,000

それとも、このようなデータは絶対に存在しない、ということ
ですか？もし、そのようなデータは絶対に存在しないという
ことであれば、連想配列を使って、以下のように設定
できます。もし存在するなら他の方法を考える必要が
ありますが。
テキストボックスはTextBox1～TextBox3を用意します。
Private Sub ComboBox1_Enter()
のところは、ボタンクリック、あるいは
Private Sub UserForm_Initialize()
で設定してもかまいません。

Private Sub ComboBox1_Enter()
'コンボボックス1へのデータ設定
Dim dic As Object
Dim i As Long
Dim j As Long
Dim l As Long
Dim v As Variant
Dim k As Variant

Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
v = Cells(i, 1).Value
If Not dic.Exists(v) Then
dic.Add v, v
End If
Next i

k = dic.keys
For l = 0 To dic.Count - 1
Me!ComboBox1.List = k
Next l

Set dic = Nothing
End Sub

Private Sub ComboBox1_Change()
'コンボボックス2へのデータ設定
Dim dic As Object
Dim j As Long
Dim l As Long
Dim v As Variant
Dim k As Variant

Me!ComboBox2.Clear
Set dic = CreateObject("Scripting.Dictionary")

For j = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
If CStr(Cells(j, "A")) = CStr(ComboBox1) Then
v = Cells(j, "B").Value
If Not dic.Exists(v) Then
dic.Add v, v
End If
End If
Next j

k = dic.keys
For l = 0 To dic.Count - 1
Me!ComboBox2.List = k
Next l

Set dic = Nothing
End Sub

Private Sub ComboBox2_Change()
'コンボボックス3へのデータ設定
Dim dic As Object
Dim j As Long
Dim l As Long
Dim v As Variant
Dim k As Variant

Me!ComboBox3.Clear
Set dic = CreateObject("Scripting.Dictionary")

For j = 1 To Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
If CStr(Cells(j, "A")) = CStr(ComboBox1) And CStr(Cells(j, "B")) = CStr(ComboBox2) Then
v = Cells(j, "C")
If Not dic.Exists(v) Then
dic.Add v, v
End If
End If
Next j

k = dic.keys
For l = 0 To dic.Count - 1
Me!ComboBox3.List = k
Next l

Set dic = Nothing
End Sub

Private Sub ComboBox3_Change()
'D列、E列分をテキストボックス１，２に反映
Dim j As Long
For j = 1 To Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If CStr(Cells(j, "A")) = CStr(ComboBox1) And CStr(Cells(j, "B")) = CStr(ComboBox2) And CStr(Cells(j, "C")) = CStr(ComboBox3) Then
Me!TextBox1 = Cells(j, "D")
Me!TextBox2 = Cells(j, "E")
End If
Next j
End Sub

回答No.3

mitarashi

#2です。第３の方法によるコードも、お役に立たないと思いますが投稿しておきます。
こちらは、ご質問とは異なり、絞り込んだ結果（複数）をリストボックスに表示（データの全列）する様にしております。

Dim myDic As Object, myDic2 As Object, myDic3 As Object
Dim myColumnsCount As Long

Private Sub UserForm_Initialize()
Dim i As Long
Dim tempCollection As Collection
Dim sh As Worksheet
Dim strWidth As String
Dim targetRange As Range, myRange As Range

Set myDic = CreateObject("Scripting.Dictionary")
Set sh = ThisWorkbook.Sheets(1)
With sh
Set targetRange = .Range("A1").CurrentRegion
Set targetRange = Intersect(targetRange, targetRange.Offset(1, 0))
End With
myColumnsCount = targetRange.Columns.Count
For Each myRange In targetRange.Columns(1).Cells
If Not myDic.exists(CStr(myRange.Value)) Then
Set tempCollection = New Collection
tempCollection.Add myRange
myDic.Add CStr(myRange.Value), tempCollection
Set tempCollection = Nothing
Else
myDic.Item(CStr(myRange.Value)).Add myRange
End If
Next myRange
ComboBox1.List = myDic.keys
strWidth = Application.WorksheetFunction.Rept("50;", myColumnsCount)
strWidth = Left(strWidth, Len(strWidth) - 1)
With ListBox1
.ColumnCount = myColumnsCount
.ColumnWidths = strWidth
End With
End Sub

Private Sub ComboBox1_Change()
Dim myKey As Variant, myKeys As Variant
Dim myRange As Range
Dim i As Long
Dim tempCollection As Collection

If ComboBox1.Value = "" Then Exit Sub
Set myDic2 = CreateObject("Scripting.Dictionary")
For i = 1 To myDic.Item(ComboBox1.Value).Count
Set myRange = myDic.Item(ComboBox1.Value).Item(i)
With myRange
If Not myDic2.exists(CStr(.Offset(0, 1).Value)) Then
Set tempCollection = New Collection
tempCollection.Add myRange
myDic2.Add CStr(.Offset(0, 1).Value), tempCollection
Set tempCollection = Nothing
Else
myDic2.Item(CStr(.Offset(0, 1).Value)).Add myRange
End If
End With
Next i
ComboBox2.List = myDic2.keys
End Sub

Private Sub ComboBox2_Change()
Dim myRange As Range
Dim i As Long
Dim tempCollection As Collection
Dim myKeys As Variant

If ComboBox2.Value = "" Then Exit Sub
Set myDic3 = CreateObject("Scripting.Dictionary")
For i = 1 To myDic2.Item(ComboBox2.Value).Count
Set myRange = myDic2.Item(ComboBox2.Value).Item(i)
With myRange
If Not myDic3.exists(CStr(.Offset(0, 2).Value)) Then
Set tempCollection = New Collection
tempCollection.Add myRange
myDic3.Add CStr(.Offset(0, 2).Value), tempCollection
Set tempCollection = Nothing
Else
myDic3.Item(CStr(.Offset(0, 2).Value)).Add myRange
End If
End With
Next i
myKeys = myDic3.keys
If myDic3.Count = 1 Then
setListBox myDic3.Item(myKeys(0))
Else
ComboBox3.List = myDic3.keys
End If
End Sub

Private Sub ComboBox3_Change()
If ComboBox3.Value = "" Then Exit Sub
setListBox myDic3.Item(ComboBox3.Value)
End Sub

Private Sub setListBox(myCollection As Collection)
Dim mydata() As Variant
Dim myRange As Range
Dim i As Long, j As Long

ReDim mydata(myColumnsCount - 1, myCollection.Count - 1)
For i = 1 To myCollection.Count
Set myRange = myCollection.Item(i)
With myRange
For j = 1 To myColumnsCount
mydata(j - 1, i - 1) = myRange.Offset(0, j - 1).Value
Next j
End With
Next i
ListBox1.Column() = mydata
End Sub

回答No.1

piroin654

>行ごとに1,2,3...と番号を振るようにしており

これは、たとえばG列に番号が振ってあると
解釈していいのですか。

お礼

お礼が遅くなり申し訳ありませんでした
ありがとうございます

補足

言葉足らずですいません
シートが2枚有り、シート1が入力のシートで
シート2がリスト表となっております
シート1のA列に自動で番号付加としております