連続プルダウンについて

質問

VBAで初心者でリストを作るのがやっとで連続プルダウンができません
各月のシートに登録ボタン作成あります。登録ボタンを押して商品を登録する際に、大分類を選んだら、選んだ大分類の中分類を選べ、中分類を選んだら小分類を選べるようにしたいです。
そのために、Sheet1に分類の表を作成しました。

例えば、大分類で梱包作業用品を選んだら、
　　　　中分類には梱包／結束用品かテープ製品が選べて、中分類で梱包／結束用品を選んだら
　　　　小分類で緩衝材か養生用ﾃｰﾌﾟが選べる様にしたいです。

どうか教えて下さい。
-----------------------------------------------------------

Private Sub CommandButton1_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet

With ws
lRow = .Range("B" & Rows.Count).End(xlUp).Row
.Range("B" & lRow + 1).Value = TextBox1.Value
lRow = Range("C" & Rows.Count).End(xlUp).Row
.Range("C" & lRow + 1).Value = ListBox1.Value
lRow = .Range("D" & Rows.Count).End(xlUp).Row
.Range("D" & lRow + 1).Value = TextBox2.Value
lRow = .Range("E" & Rows.Count).End(xlUp).Row
.Range("E" & lRow + 1).Value = TextBox3.Value
lRow = .Range("F" & Rows.Count).End(xlUp).Row
.Range("F" & lRow + 1).Value = TextBox4.Value
lRow = .Range("G" & Rows.Count).End(xlUp).Row
.Range("G" & lRow + 1).Value = TextBox5.Value
'lRow = .Range("I" & Rows.Count).End(xlUp).Row
'.Range("I" & lRow + 1).Value = TextBox6.Value
lRow = Range("I" & Rows.Count).End(xlUp).Row
.Range("I" & lRow + 1).Value = ListBox3.Value
lRow = .Range("J" & Rows.Count).End(xlUp).Row
.Range("J" & lRow + 1).Value = TextBox7.Value
lRow = .Range("K" & Rows.Count).End(xlUp).Row
.Range("K" & lRow + 1).Value = TextBox8.Value
lRow = Range("L" & Rows.Count).End(xlUp).Row
Range("L" & lRow + 1).Value = ListBox2.Value
lRow = .Range("H" & Rows.Count).End(xlUp).Row
.Range("H" & lRow + 1).Value = TextBox9.Value
End With
TextBox1.Value = ""
TextBox1.SetFocus
TextBox2.Value = ""
TextBox2.SetFocus
TextBox3.Value = ""
TextBox3.SetFocus
TextBox4.Value = ""
TextBox4.SetFocus
TextBox5.Value = ""
TextBox5.SetFocus
'TextBox6.Value = ""
'TextBox6.SetFocus
TextBox7.Value = ""
TextBox7.SetFocus
TextBox8.Value = ""
TextBox8.SetFocus
TextBox9.Value = ""
TextBox9.SetFocus
End Sub
Private Sub UserForm_Initialize()
With ListBox1
.AddItem "たのめーる"
.AddItem "AMAZON"
.AddItem "楽天"
.AddItem "yahooショッピング"
.AddItem "国峰印房"
.AddItem "脇製茶"
.AddItem "ヤマト運輸"
.AddItem "ゼネラル"
.AddItem "家電量販店"
End With
With ListBox2
.AddItem "総務課"
.AddItem "用度"
.AddItem "営業"
.AddItem "介護"
.AddItem "倉庫"
.AddItem "人事"
.AddItem "経理"

End With
With ListBox3
.AddItem "梱包作業用品"
.AddItem "事務用品消耗品"
.AddItem "パソコン用品消耗品"
.AddItem "プリンター用品消耗品"
.AddItem "掃除用品消耗品"
.AddItem "衛生用品消耗品"
.AddItem "消臭用品消耗品"
.AddItem "洗剤用品消耗品"
.AddItem "事務用品"
.AddItem "掃除用品"
.AddItem "生活雑貨用品"
.AddItem "飲食用品"
.AddItem "パソコン周辺機器"
.AddItem "生活雑貨"
.AddItem "医療機器"
.AddItem "電化製品"
.AddItem "衛生用品"
.AddItem "日用品"
.AddItem "出版物"
.AddItem "家具"
End With

End Sub

回答No.8

kkkkkm

No7の補足です。

「参照設定」で「Microsoft ActiveX Data Objects 2.X Library」を追加しておいてください。

お礼

ありがとうございます。

回答No.7

kkkkkm

No4のコードを同じところをFunctionとしてまとめたものです。
ShName = "Sheet2"のSheet2を本来のシート名に変更してください。
それぞれのリストボックス名は大分類,中分類,小分類としてください。

Private Sub UserForm_Initialize()
Dim strSQL As String
Dim ShName As String

ShName = "Sheet2"

strSQL = ""
strSQL = strSQL & "SELECT [" & ShName & "$].大分類"
strSQL = strSQL & " FROM [" & ShName & "$]"
strSQL = strSQL & " GROUP BY [" & ShName & "$].大分類; "

Call mRunSQL(Me.大分類, strSQL, "大分類")
End Sub

Private Sub 大分類_Change()
Dim strSQL As String
Dim ShName As String

ShName = "Sheet2"

strSQL = ""
strSQL = strSQL & "SELECT [" & ShName & "$].中分類"
strSQL = strSQL & " FROM [" & ShName & "$]"
strSQL = strSQL & " GROUP BY [" & ShName & "$].中分類,[" & ShName & "$].大分類 "
strSQL = strSQL & " HAVING ((([" & ShName & "$].大分類)=" & """" & Me.大分類.Text & """" & "));"

Call mRunSQL(Me.中分類, strSQL, "中分類")
End Sub

Private Sub 中分類_Change()
Dim strSQL As String
Dim ShName As String

ShName = "Sheet2"

strSQL = ""
strSQL = strSQL & "SELECT [" & ShName & "$].小分類"
strSQL = strSQL & " FROM [" & ShName & "$]"
strSQL = strSQL & " WHERE ((([" & ShName & "$].大分類)=" & """" & Me.大分類.Text & """" & ") AND (([" & ShName & "$].中分類)=" & """" & Me.中分類.Text & """" & "));"

Call mRunSQL(Me.小分類, strSQL, "小分類")

End Sub

Function mRunSQL(ByRef mList As Control, ByVal strSQL As String, ByVal Catergory As String)
Dim objCn As New ADODB.Connection
Dim objRS As ADODB.Recordset

mList.Clear
With objCn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties") = "Excel 8.0"
.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
End With

Set objRS = New ADODB.Recordset
Set objRS = objCn.Execute(strSQL)

Do Until objRS.EOF
mList.AddItem objRS(Catergory)
objRS.MoveNext
Loop
objCn.Close
Set objRS = Nothing
Set objCn = Nothing
End Function

お礼

ありがとうございます。

回答No.6

HohoPapa

SQLを使って書いてみました。
よかったら試してみてください。

'Sheet1モジュール===========

Option Explicit
Private Sub CommandButton1_Click()
　UserForm1.Show
End Sub

'UserForm1モジュール===========

Option Explicit
Private Sub UserForm_Initialize()
　Set1
End Sub
Private Sub ListBox1_Change()
　Set2
End Sub
Private Sub ListBox2_Change()
　Set3
End Sub

'標準モジュール===========
Option Explicit

Sub Set1()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object

　'SQL全文を組み立て
　SQL = "SELECT [大分類]" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "GROUP BY [大分類]" & vbCrLf
　SQL = SQL & "ORDER BY [大分類]" & vbCrLf

　'SQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　UserForm1.ListBox1.Clear
　UserForm1.ListBox2.Clear
　UserForm1.ListBox3.Clear
　If Not rs.EOF Or Not rs.Bof Then
　　rs.MoveFirst
　　Do
　　　If rs.EOF = True Then Exit Do
　　　With UserForm1.ListBox1
　　　　.AddItem rs("大分類")
　　　End With
　　　rs.MoveNext
　　Loop
　End If

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

Sub Set2()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object

　'SQL全文を組み立て
　SQL = "SELECT [中分類]" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "Where [大分類]='" & UserForm1.ListBox1.Text & "'" & vbCrLf
　SQL = SQL & "GROUP BY [中分類]" & vbCrLf
　SQL = SQL & "ORDER BY [中分類]" & vbCrLf

　'SQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　UserForm1.ListBox2.Clear
　UserForm1.ListBox3.Clear

　If Not rs.EOF Or Not rs.Bof Then
　　rs.MoveFirst
　　Do
　　　If rs.EOF = True Then Exit Do
　　　With UserForm1.ListBox2
　　　　.AddItem rs("中分類")
　　　End With
　　　rs.MoveNext
　　Loop
　End If

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

Sub Set3()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object

　'SQL全文を組み立て
　SQL = "SELECT [小分類]" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "Where ([大分類]='" & UserForm1.ListBox1.Text & "' ) and" & vbCrLf
　SQL = SQL & "　　　([中分類]='" & UserForm1.ListBox2.Text & "' ) " & vbCrLf
　SQL = SQL & "GROUP BY [小分類]" & vbCrLf
　SQL = SQL & "ORDER BY [小分類]" & vbCrLf

　'SQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　UserForm1.ListBox3.Clear
　If Not rs.EOF Or Not rs.Bof Then
　　rs.MoveFirst
　　Do
　　　If rs.EOF = True Then Exit Do
　　　With UserForm1.ListBox3
　　　　.AddItem rs("小分類")
　　　End With
　　　rs.MoveNext
　　Loop
　End If

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

回答No.5

kkkkkm

No4の追加です。

念のために
Set objRS = Nothing
を各プロシージャの
Set objCn = Nothing
の前に入れておいてください。

また、それぞれのプロシージャはほとんど同じようなものなのでFunctionとしてまとめたらいいのですが面倒なのでやってません。

回答No.4

kkkkkm

質問の添付画像のままのデータでしたら(SHeet2にデータがあるとして)「参照設定」で「Microsoft ActiveX Data Objects 2.X Library」を追加してフォームのプロシージャに以下をコピペで試してみてください。

Private Sub UserForm_Initialize()
Dim objCn As New ADODB.Connection
Dim objRS As ADODB.Recordset
Dim strSQL As String

With objCn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties") = "Excel 8.0"
.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
End With

strSQL = ""
strSQL = strSQL & "SELECT [Sheet2$].大分類"
strSQL = strSQL & " FROM [Sheet2$]"
strSQL = strSQL & " GROUP BY [Sheet2$].大分類; "

Set objRS = New ADODB.Recordset
Set objRS = objCn.Execute(strSQL)

Do Until objRS.EOF
Me.大分類.AddItem objRS!大分類
objRS.MoveNext
Loop
objCn.Close
Set objCn = Nothing
End Sub

Private Sub 大分類_Change()
Dim objCn As New ADODB.Connection
Dim objRS As ADODB.Recordset
Dim strSQL As String

Me.中分類.Clear
With objCn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties") = "Excel 8.0"
.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
End With

strSQL = ""
strSQL = strSQL & "SELECT [Sheet2$].中分類"
strSQL = strSQL & " FROM [Sheet2$]"
strSQL = strSQL & " GROUP BY [Sheet2$].中分類,[Sheet2$].大分類 "
strSQL = strSQL & " HAVING ((([Sheet2$].大分類)=" & """" & Me.大分類.Text & """" & "));"

Set objRS = New ADODB.Recordset
Set objRS = objCn.Execute(strSQL)

Do Until objRS.EOF
Me.中分類.AddItem objRS!中分類
objRS.MoveNext
Loop
objCn.Close
Set objCn = Nothing
End Sub

Private Sub 中分類_Change()
Dim objCn As New ADODB.Connection
Dim objRS As ADODB.Recordset
Dim strSQL As String

Me.小分類.Clear
With objCn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties") = "Excel 8.0"
.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
End With

strSQL = ""
strSQL = strSQL & "SELECT [Sheet2$].小分類"
strSQL = strSQL & " FROM [Sheet2$]"
strSQL = strSQL & " WHERE ((([Sheet2$].大分類)=" & """" & Me.大分類.Text & """" & ") AND (([Sheet2$].中分類)=" & """" & Me.中分類.Text & """" & "));"

Set objRS = New ADODB.Recordset
Set objRS = objCn.Execute(strSQL)

Do Until objRS.EOF
Me.小分類.AddItem objRS!小分類
objRS.MoveNext
Loop
objCn.Close
Set objCn = Nothing
End Sub

回答No.3

kkkkkm

データを添付画像のようにしていただいて(画像はテスト的に一部です)
以下のコードで試してみてください。

Private Sub UserForm_Initialize()
Dim i As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

For i = 1 To ws.Cells(1, Columns.Count).End(xlToRight).Column
Me.大分類.AddItem ws.Cells(1, i)
Next i

End Sub

Private Sub 大分類_Change()
Dim i As Long
Dim Fb As Range
Dim FirstRow As Long, EndRow As Long
Dim TitleRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

TitleRow = 1
FirstRow = 2
EndRow = 9

Me.中分類.Clear
With ws
Set Fb = .Range(.Cells(TitleRow, "A"), .Cells(TitleRow, Columns.Count).End(xlToLeft)).Find(What:=Me.大分類.Text, LookIn:=xlValues, LookAt:=xlWhole)
If Not Fb Is Nothing Then
For i = FirstRow To .Cells(EndRow, Fb.Column).End(xlUp).Row
Me.中分類.AddItem .Cells(i, Fb.Column)
Next i
End If
End With
Set ws = Nothing
End Sub

Private Sub 中分類_Change()
Dim i As Long
Dim Fb As Range
Dim FirstRow As Long, EndRow As Long
Dim TitleRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

TitleRow = 10
FirstRow = 11
EndRow = 19

Me.小分類.Clear
With ws
Set Fb = .Range(.Cells(TitleRow, "A"), .Cells(TitleRow, Columns.Count).End(xlToLeft)).Find(What:=Me.中分類.Text, LookIn:=xlValues, LookAt:=xlWhole)
If Not Fb Is Nothing Then
For i = FirstRow To .Cells(EndRow, Fb.Column).End(xlUp).Row
Me.小分類.AddItem .Cells(i, Fb.Column)
Next i
End If
End With
Set ws = Nothing
End Sub

お礼

ありがとうございます。

回答No.2

imogasi

#1です。書き忘れたが、Googleで「エクセル ドロップダウンリスト 多段」で照会でもして、記事を読んで、参考にして、考えたか？または「エクセル　VBA ドロップダウンリスト 多段 」で
たくさん記事があり、数個に目を通せば、参考になるだろう。
そしたら、ここへの、質問の書き方も変わるのではないか（自分の一方的なコードを挙げて読ませるのでなくて）。VBAコード的に、的が絞れると思う。

回答No.1

imogasi

よくある課題だ。長々と説明しなくても、「あれだな」とわかる。
しかしACCSSVBAなど、SQLを使えるものと違って、エクセルでは、抜出し（選択）が、VBAでは
複雑になるので、やる気がしない。
エクセルで該当するものを抜き出すのはFilterだが、これでやれるかやってみたら。
エクセルの入力規則の、リストでも２段階ぐらいなら、VBAを使わなくてもやる方法が、WEBに載っているのではと思う。エクセルでもADOを使ってSQLのSELECT文を使う方法は、WEBに載っているから、勉強する手がある。この辺になると、知らない世界に入る方法もあるので、周りに良き指導者が必要と思う。
丸投げで帰ってきたコードや、説明文章だけで達成できるとは思わない。
　初心者に、課題だけは、一般普通のものを割り当てられて、どうにかするのは、難しい。長年の色んなタイプの型を課題を経験して、貯めておいて、初めてある時に、役に立つというのが通例と思う。
もし、この問題の回答者が出ても、その人は、多分過去の他言語のJAVAなどの経験や、仕事経験のある人と推測する。

お礼

ありがとうございます。