VBA ユーザーフォーム　コンボボックスについて

VBAのフォーム画面にコンボボックスを設置しました。
ユーザーフォーム：UserForm1
データ：datasheet
A列:No.
B列：製品名
C列：サイズ
D列：数量

画面上にコンボボックス１,2,3があり、入力リストをdatasheetから表示します。
コンボボックス２は、コンボボックス１で選択されたものに対応するデータだけが選択可能です。
コンボボックス3は、コンボボックス１、2で選択されたものに対応するデータだけが選択可能です。

＜実現したいこと、知りたいこと＞
VBA ユーザーフォームのコンボボックスはひらがな、漢字、ローマ字は問題なかったのですが、下記C列とD列リストが表示されませんでした。
以下のことを実行するにはどのように記述すればよろしいでしょうか？
①datasheetC列は半角小数点
②datasheetD列は半角数字、マイナス(-20,-50など）もある。
よろしければ、ご教授いただきたく、よろしくお願いいたします。

VBA
1Private Sub ComboBox2_Change()
2
3Dim MyData3 As New Collection
4Dim cnt3 As Long
5Dim i3 As Long
6
7
8cnt3 = Sheets("datasheet").Range("A1").CurrentRegion.Rows.Count
9
10製品名 = ComboBox1.Text
11サイズ = ComboBox2.Text
12
13ComboBox3.Clear
14
15    On Error Resume Next
16    For i3 = 2 To cnt3
17
18      If Sheets("datasheet").Range("B" & i3).Value = 製品名 Then
19
20        If Sheets("datasheet").Range("C" & i3).Value = サイズ Then
21            MyData3.Add Sheets("datasheet").Range("D" & i3).Value, Sheets("datasheet").Range("D" & i3).Value
22        End If
23    End If
24
25    Next i3
26    On Error GoTo 0
27
28    For i3 = 1 To MyData3.Count
29
30      ComboBox3.AddItem MyData3(i3)
31    Next
32
33
34End Sub
35Private Sub ComboBox1_Change()
36Dim MyData2 As New Collection
37Dim cnt2 As Long
38Dim i2 As Long
39
40
41cnt2 = Sheets("datasheet").Range("A1").CurrentRegion.Rows.Count
42
43製品名 = ComboBox1.Text
44
45ComboBox2.Clear
46
47    '■重複しない製品名のリストを作成
48    On Error Resume Next
49    For i2 = 2 To cnt2
50
51      If Sheets("datasheet").Range("B" & i2).Value = 製品名 Then
52
53        MyData2.Add Sheets("datasheet").Range("C" & i2).Value, Sheets("datasheet").Range("C" & i2).Value
54    End If
55
56    Next i2
57    On Error GoTo 0
58
59    '■製品名のリストを作成
60
61    For i2 = 1 To MyData2.Count
62
63      ComboBox2.AddItem MyData2(i2)
64    Next
65
66
67End Sub
68
69Private Sub UserForm_Initialize()
70Dim MyData1 As New Collection
71
72Dim cnt As Long
73Dim i As Long
74
75    cnt = Sheets("datasheet").Range("A1").CurrentRegion.Rows.Count
76
77    '■重複しない製品名のリストを作成
78    On Error Resume Next
79    For i = 2 To cnt
80
81        MyData1.Add Sheets("datasheet").Range("B" & i).Value, Sheets("datasheet").Range("B" & i).Value
82
83    Next i
84    On Error GoTo 0
85
86    '■製品名のリストを作成
87
88    For i = 1 To MyData1.Count
89
90      ComboBox1.AddItem MyData1(i)
91    Next
92
93End Sub
94

meg_

2020/10/11 12:26

「On Error Resume Next」を削除してエラーが発生していないか確認しましょう。

koko2

2020/10/12 02:12

確認方法を教えてくださりありがとうございました。

行動規範の内容に同意します

回答2件

ベストアンサー

質問者様
今回うまくいかなかった原因はCollectionのキーに数値を使用しようとした為です。
Collectionのキーには文字列しか使えませんのでそのように対応しました。
コンボボックスの値は「数値」ではなく「数字」ですのでこの後の処理で間違いなきようお願いします。

あとCollectionに無理やりAddして重複を除外するのは強引なので
「isExists」という関数を用意しました。
【VBA入門】Collectionオブジェクトの使い方

回答は以上となります

VBA
1Private Sub ComboBox2_Change()
2
3    Dim MyData3 As New Collection
4    Dim cnt3 As Long
5    Dim i3 As Long
6    Dim ProductName As Variant  '製品名
7    Dim Size        As Variant  'サイズ
8    
9    cnt3 = Sheets("datasheet").Range("A1").CurrentRegion.Rows.Count
10    
11    ProductName = ComboBox1.Text
12    Size = ComboBox2.Text
13    
14    ComboBox3.Clear
15
16    'On Error Resume Next
17    For i3 = 2 To cnt3
18        If CStr(Sheets("datasheet").Range("B" & i3).Value) = ProductName _
19        And CStr(Sheets("datasheet").Range("C" & i3).Value) = Size Then
20            key = CStr(Sheets("datasheet").Range("D" & i3).Value)
21            If isExists(MyData3, key) = False Then
22                MyData3.Add key, key
23            End If
24        End If
25    Next i3
26    'On Error GoTo 0
27
28    For i3 = 1 To MyData3.Count
29        ComboBox3.AddItem MyData3(i3)
30    Next
31
32End Sub
33Private Sub ComboBox1_Change()
34    Dim MyData2 As New Collection
35    Dim cnt2 As Long
36    Dim i2 As Long
37    Dim key         As Variant
38    Dim ProductName As Variant  '製品名
39    
40    cnt2 = Sheets("datasheet").Range("A1").CurrentRegion.Rows.Count
41    
42    ProductName = ComboBox1.Text
43    
44    ComboBox2.Clear
45
46    '■重複しないProductNameのリストを作成
47    'On Error Resume Next
48    For i2 = 2 To cnt2
49        If CStr(Sheets("datasheet").Range("B" & i2).Value) = ProductName Then
50            key = CStr(Sheets("datasheet").Range("C" & i2).Value)
51            If isExists(MyData2, key) = False Then
52                MyData2.Add key, key
53            End If
54        End If
55    Next i2
56    'On Error GoTo 0
57
58    '■ProductNameのリストを作成
59
60    For i2 = 1 To MyData2.Count
61        ComboBox2.AddItem MyData2(i2)
62    Next
63
64
65End Sub
66
67Private Sub UserForm_Initialize()
68    Dim MyData1 As New Collection
69    
70    Dim cnt As Long
71    Dim i As Long
72    Dim key         As Variant
73
74    cnt = Sheets("datasheet").Range("A1").CurrentRegion.Rows.Count
75
76    '■重複しないProductNameのリストを作成
77    'On Error Resume Next
78    For i = 2 To cnt
79        key = CStr(Sheets("datasheet").Range("B" & i).Value)
80        If isExists(MyData1, key) = False Then
81            MyData1.Add key, key
82        End If
83    Next i
84    'On Error GoTo 0
85
86
87    '■ProductNameのリストを作成
88
89    For i = 1 To MyData1.Count
90        ComboBox1.AddItem MyData1(i)
91    Next
92
93End Sub
94' Collectionの中にすでに登録されているか確認
95Function isExists(col As Collection, item As Variant) As Boolean
96    Dim Var As Variant
97    For Each Var In col
98        If Var = item Then
99            isExists = True
100            Exit Function
101        End If
102    Next Var
103    isExists = False
104End Function

投稿2020/10/11 14:16

kuma_kuma_

総合スコア2506

koko2

2020/10/12 05:34

ありがとうございました。Collectionのキーには文字列しか使えない事勉強になりました。isExistsについてや、CStrについてもよく知らなかったので勉強になりました。実現したいことが再現されました。

koko2

2020/10/12 05:39

今後、下にコンボボックスが増えることが予想されます。Private Sub ComboBox2_Change()を参考として追加も可能でしょうか？

kuma_kuma_

2020/10/12 06:18

大丈夫ですよ。

koko2

2020/10/13 11:53

ありがとうございました。実際の環境で実行したり、コンボボックス７くらいまで作成してみたりしても問題なく実行できました。

行動規範の内容に同意します

以前、似たようなものを作成したことがありますので、思い出して作成してみました。
コンボボックスのリストデータはDictionaryに格納するようにしました。

Collectionでもいいのですが、Dictionaryは Keysでキーの配列を取得できますので、それをコンボボックスのListに直接代入出来るので楽ができます。
また、すでに登録されているかの確認も Existsメソッドでできます。

ユーザーフォームのInitializeイベントで、ComboBox1用のDictionaryのアイテムにComboBox2用のDictionary、さらにComboBox2用のDictionaryのアイテムにComboBox3用のDictionaryを格納するという、入れ子構造にして、全てのコンボボックスのリストデータを格納するようにしました。

ComboBox1、ComboBox2のAfterUpdateイベントでは、入れ子構造のDictionaryからリストデータを取り出してコンボボックスのListに代入すればいいだけになります。

Changeイベントはコンボボックスで一文字入力したり削除しただけで発生します。AfterUpdateイベントだと入力し終わってから発生するので無駄がないです。

Microsoft Scripting Runtime 参照設定必須

vba
1Option Explicit
2Dim dicList As Dictionary
3
4Private Sub ComboBox1_AfterUpdate()
5    Dim dicList2 As Dictionary
6    If dicList.Exists(Me.ComboBox1.Text) Then
7        Set dicList2 = dicList(Me.ComboBox1.Text)
8        Me.ComboBox2.List = dicList2.Keys
9        Me.ComboBox2.Value = ""
10        Me.ComboBox3.Value = ""
11    End If
12End Sub
13
14Private Sub ComboBox2_AfterUpdate()
15    Dim dicList2 As Dictionary
16    Set dicList2 = dicList(Me.ComboBox1.Text)
17    Dim dicList3 As Dictionary
18    If dicList2.Exists(Me.ComboBox2.Text) Then
19        Set dicList3 = dicList2(Me.ComboBox2.Text)
20        Me.ComboBox3.List = dicList3.Keys
21        Me.ComboBox3.Value = ""
22    End If
23End Sub
24
25Private Sub UserForm_Initialize()
26    Dim aryData()
27     With Worksheets("DataSheet").Range("A1").CurrentRegion
28        aryData = .Offset(1, 1).Resize(.Rows.Count - 1, 3).Value
29    End With
30    
31    Set dicList = New Dictionary   
32    Dim i As Long
33    For i = 1 To UBound(aryData)
34        Dim dicList2 As Dictionary
35        If dicList.Exists(aryData(i, 1)) Then
36            Set dicList2 = dicList(aryData(i, 1))
37        Else
38            Set dicList2 = New Dictionary
39        End If
40        
41        Dim dicList3 As Dictionary
42        If dicList2.Exists(CStr(aryData(i, 2))) Then
43            Set dicList3 = dicList2(CStr(aryData(i, 2)))
44        Else
45            Set dicList3 = New Dictionary
46        End If
47        dicList3(CStr(aryData(i, 3))) = aryData(i, 3)        
48        Set dicList2(CStr(aryData(i, 2))) = dicList3
49        Set dicList(CStr(aryData(i, 1))) = dicList2
50    Next
51    Me.ComboBox1.List = dicList.Keys
52End Sub