VBAで2つのリストボックスの連動表示に関して

質問

VBAで2つのリストボックスの連動表示に関して、
ご教授、お願い致します。

VBAで色々、試行錯誤しております初心者です。
今回の質問ですけど、参考にWebで調べたのですが
分からなく、どのようにしたらいいのか
教えて頂けないでしょうか。

（例　リスト表）
Sheet1（取引名簿）
　　　（No.）　（取引番号）　（取引社名）　　　　　　　　　　　　　　　　　　
　　　A列　　　　B列　　　　　C列　　　　・・・　　　　　　　　　　　　　　　
1　　　1　　　A-0001　　　　 A社 　　　・・・　　　　　　　　　　　　
2　　　2　　　B-0001 B社 　　　 ・・・
3　　　3　　　A-0002 C社 　　　・・・
4　　　4　　　A-0003　 D社 　　　 ・・・
5　　　5　　　B-0002 E社　　　 ・・・
・
・
・

Sheet2（顧客名簿）
（No.）　（取引社名）　（顧客名）
A列　　　　B列　　　　　C列　　　・・・
1　　　1 A社　　　　 顧客1 ・・・
2　　　2　　　　 B社 顧客2　 ・・・
3　　　3　　　 A社 　 顧客3 ・・・
4　　　4　　　 C社 　 顧客4 ・・・
5　　　5 A社 顧客5 ・・・
・
・
・

上記、例題　2つのシートリストを条件に合わせ、2つ目のリストボックスに
連動表示させたいのですが処理できるように教えて頂けないでしょうか。
※ ListBox1　に　Sheet1　の　B列（取引番号）　と　C列（取引社名）　を表示し、
ListBox2　には、　Sheet1　で選択した取引会社に連動し、
C列の顧客(条件一致者）全員を ListBox2に表示したいのです。

(例)
ListBox1でSheet1の中からA社を選択したとします。
連動でListBox2には、A社の顧客1、顧客3、顧客5が表示するように出来ないでしょうか。

説明下手で申し訳ありませんが宜しくお願い致します。

回答No.1

mitarashi · ベストアンサー

ACE.OLEDBプロバイダになって自ブックに使っても問題がなくなったとの事で、最近自ブックへのADOの適用に凝っています。
Excel2007以降対応です。少し変更すれば2003以前でも動きますが、バグがあるそうなのでお勧めしません。
気楽に始めましたが、意外なところ（複数）ではまってしまいました。
シート1に置いたコントロールツールボックスのListBoxで試しています。参照データのあるシートは、名前（取引名簿、顧客名簿）で指定しています。
UserF0rmへの載せ替えは容易と思います。
Worksheet_Activateで初期設定していますので、シートを一旦切り替える必要があります。

Microsoft ActiveX Data Objects Libraryに参照設定が必要です。必要により下記をご覧下さい。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_040_04.html
http://www.happy2-island.com/access/gogo03/capter00307.shtml

'☆ Sheet1のシートモジュールに記載
Dim cn As ADODB.Connection

'http://support.microsoft.com/kb/257819

Private Sub Worksheet_Activate()
Dim rs As ADODB.Recordset
Dim SQL As String
Dim i As Long, j As Long

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties").Value = "Excel 12.0 Macro;HDR=YES"
.Open ThisWorkbook.FullName
End With

SQL = "SELECT [取引番号],[取引社名] FROM [取引名簿$]"
rs.Open SQL, cn, adOpenStatic, adLockReadOnly
If rs.BOF Then
MsgBox "該当するデータは存在しません", vbCritical
rs.Close
Set rs = Nothing
Exit Sub
End If
Me.ListBox1.Clear
Me.ListBox2.Clear
With Me.ListBox1
.ColumnCount = rs.Fields.Count
.ColumnWidths = "50;50"
i = 0
Do Until rs.EOF
.AddItem rs.Fields(0).Value
For j = 1 To rs.Fields.Count - 1
.List(i, j) = rs.Fields(j).Value
Next j
rs.MoveNext
i = i + 1
Loop
End With
If rs.State = 1 Then rs.Close
Set rs = Nothing
End Sub

Private Sub Worksheet_Deactivate()
On Error Resume Next

cn.Close
Set cn = Nothing
End Sub

Private Sub ListBox1_Click()
Dim rs As ADODB.Recordset
Dim SQL As String
Dim i As Long, j As Long

Set rs = New ADODB.Recordset

SQL = "SELECT [顧客名] FROM [顧客名簿$] WHERE [取引社名]='myCriteria';"
SQL = Replace(SQL, "myCriteria", Me.ListBox1.List(Me.ListBox1.ListIndex, 1))
rs.Open SQL, cn, adOpenStatic, adLockReadOnly
If rs.BOF Then
MsgBox "該当するデータは存在しません", vbCritical
rs.Close
Set rs = Nothing
Exit Sub
End If
With Me.ListBox2
.Clear
Do Until rs.EOF
.AddItem rs.Fields(0).Value
rs.MoveNext
Loop
End With
If rs.State = 1 Then rs.Close
Set rs = Nothing
End Sub

Private Sub ListBox2_Click()
MsgBox Me.ListBox2.List(Me.ListBox2.ListIndex)
End Sub

※他にもいろいろな方法がありますが、本方法はSQLの若干の知識があれば、やっている事は簡単です。
http://okwave.jp/qa/q6933753.html#answer

お礼

mitarashi さん
こんにちわ。

お礼、遅くなりまして申し訳ございません。
回答頂き、本当に有難う御座いました。

Sheet上のコントロールツールボックス（ListBox）で
試して見ました。
思っていた通りに完璧に出来ました。
今度は、自分でUserF0rmへの載せ替えを
試してみます。旨く行くか不安ですけど…。
UserF0rmへの載せ替えで注意事項及び追加提案がありましたらご享受下さい。

本当に助かりました、有難う御座いました。
また、機会がありましたら、よろしくお願いします。