VBAでコンボボックスとテキストボックスの連動

質問

業務命令でVBAの勉強を始めました。
フォームの作成を始めたところなのですが、早くもつまづいてしまい、先に進めません。
どうかご教授をお願いいたします。

現在Book1でユーザーフォームを作成しています。
別なブックBook2のSheet1にあるデータでコンボボックス とテキストボックスを連動させたいと考えております。
Book2のSheet1では、A列に会社名、B列に会社ID、C列に電話番号の表があります。

ComboBox1で会社名を選択したときに、TextBox1にその会社の会社ID、TextBox2に電話番号を表示させるにはどのようにしたらいいのでしょうか？

ネットで検索しながらフォーム作成をしており、似たような条件のコードを自分なりに修正してやってみましたがどうやっても動作しません。
どうかよろしくお願いいたします。

回答No.2

kkkkkm · ベストアンサー

No1の訂正です。

Set FRange = .Range(.Cells(2, "A"), .Cells(LastRow, "C")).Find(FStr, LookAt:=xlWhole)

は

Set FRange = .Range(.Cells(2, "A"), .Cells(LastRow, "A")).Find(FStr, LookAt:=xlWhole)

でした。

No1のComboBox1_Changeは遅いので以下のようにすれば早くなります。

Private Sub ComboBox1_Change()
Dim i As Long

With ComboBox1
i = 2
Do While ExecuteExcel4Macro("'C:\ok\[Book2.xlsx]Sheet1'!R" & i & "C1") <> 0
If .Value = ExecuteExcel4Macro("'C:\ok\[Book2.xlsx]Sheet1'!R" & i & "C1") Then
TextBox1.Value = ExecuteExcel4Macro("'C:\ok\[Book2.xlsx]Sheet1'!R" & i & "C2")
TextBox2.Value = ExecuteExcel4Macro("'C:\ok\[Book2.xlsx]Sheet1'!R" & i & "C3")
Exit Do
End If
i = i + 1
Loop
End With

End Sub

お礼

kkkkkm様、ありがとうございます。
1行ずつ調べながら作業をしており、お礼まで時間がかかってしまいました。

おかげさまで希望の動きとなったのですが、マクロが[実行中]のままになってしまいます。
■ボタンで停止をすることはできますが、何か他の方法はございませんでしょうか？

回答No.7

HohoPapa

>理解しようとしてみたのですが・・・、無理でした。
SQLは今後いろいろな局面で活用できますので
ＤＢのイロハをマスターする必要がありますが、
ぜひ克服してほしいところです。

>ただマクロが[実行中]のままになってしまいます。
VBAのフォームが開いているわけですから
開いている間は，VBAは実行中です。
が、だからといって「困った」はないはずです。

もしフォームが開いている状態で
Book1のシートを操作したいのであれば

Private Sub CommandButton1_Click()
　UserForm1.Show vbModeless
End Sub

といったコードに変更します。

お礼

ありがとうございます。
これから勉強を進めていっていつか理解できるようになりたいと思います。

実行中の件はそのままでもよかったのですね。
大変失礼いたしました。

色々教えていただきまして、ありがとうございます。

回答No.6

kkkkkm

> ファイルを開くのに時間がかかっているのだと思います。

勘違いでした。フォームを開いているので「実行中」になります。それで正常です。フォームを閉じれば「実行中」は消えます。

お礼

ありがとうございます。
このままで問題なかったのですね。
素人すぎる質問失礼いたしました。

回答No.5

kkkkkm

> おかげさまで希望の動きとなったのですが、マクロが[実行中]のままになってしまいます。

VBEのタイトルバーのところで「実行中」と出ているのだと思いますが、ファイルを開くのに時間がかかっているのだと思います。

No2のComboBox1_Change()のコードで試してみてください。

回答No.4

HohoPapa

No3の補足です。

Book1.xlsmとBook2.xlsxは同じフォルダーに配置されている前提です。
また、Book2.xlsxは
（開いていてもかまいませんが）
あえて、開いておく必要はありません。

回答No.3

HohoPapa

ちょっとハードルが上がりますが、SQL文を使う対応を紹介します。

添付画像のようにコードを配置します。

以下、画像ではあふれているModule1のコードが以下です。

Option Explicit

Sub 会社一覧表示()

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

　'SQL全文を組み立て、実行
　SQL = "SELECT *" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　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 & "\" & "Book2.xlsx"
　rs.Open SQL, cn

　If rs.EOF And rs.Bof Then
　　MsgBox "抽出結果が０レコード"
　　Exit Sub
　End If
　rs.MoveFirst
　Do
　　If rs.EOF = True Then Exit Do
　　UserForm1.ComboBox1.AddItem rs("会社名")
　　rs.MoveNext
　Loop

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

End Sub

Sub 詳細表示()
　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.ComboBox1.Text & "'" & vbCrLf

　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 & "\" & "Book2.xlsx"
　rs.Open SQL, cn

　If rs.EOF And rs.Bof Then
　　MsgBox "抽出結果が０レコード"
　　Exit Sub
　End If
　rs.MoveFirst
　UserForm1.TextBox1.Text = rs("会社ID")
　UserForm1.TextBox2.Text = rs("電話番号")

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

End Sub

お礼

HohoPapa様、ありがとうございます。
理解しようとしてみたのですが・・・、無理でした。
とりあえずコピーして使わせていただいたら希望通りに動きました。
ただマクロが[実行中]のままになってしまいます。
■ボタンで停止をすることはできますが、何か他の方法はございませんでしょうか？

回答No.1

kkkkkm

ユーザーフォームのプロシージャに以下を記載してください。
Book2の1行目は項目行で2行目から実際の会社名が入っていると考えています。
TextBox1にその会社の会社ID、TextBox2に電話番号を表示させるときが遅いと思います。Book1の別のシートにBook2のSheet1のデータを参照させておいてそちらを使った方がいいかもしれません。
Book2は閉じたままで実行してください。

C:\ok\[Book2.xlsx]Sheet1
は実際のブックのフォルダ名及びブック名とシート名に

Private Sub UserForm_Initialize()
Dim i As Long

With ComboBox1
i = 2
Do While ExecuteExcel4Macro("'C:\ok\[Book2.xlsx]Sheet1'!R" & i & "C1") <> 0
.AddItem ExecuteExcel4Macro("'C:\ok\[Book2.xlsx]Sheet1'!R" & i & "C1")
i = i + 1
Loop
End With
End Sub

'↓これがバックでファイルを開いているのでその分時間がかかると思います。
Private Sub ComboBox1_Change()
Dim FStr As String, LastRow As Long
Dim ex As New Excel.Application
Dim mPath As String
Dim wb As Workbook
Dim FRange As Range

FStr = ComboBox1.Value
mPath = "C:\ok\Book2.xlsx" '実際のフォルダとブック名に
Set wb = ex.Workbooks.Open(Filename:=mPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
With wb.Worksheets("Sheet1")　'実際のシート名に
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
TextBox1.Value = _
Application.WorksheetFunction.VLookup(FStr, .Range(.Cells(2, "A"), .Cells(LastRow, "C")), 2, False)
TextBox2.Value = _
Application.WorksheetFunction.VLookup(FStr, .Range(.Cells(2, "A"), .Cells(LastRow, "C")), 3, False)

' Findを使うこともできますがどちらも遅いと思います。
' Set FRange = .Range(.Cells(2, "A"), .Cells(LastRow, "C")).Find(FStr, LookAt:=xlWhole)
' If Not FRange Is Nothing Then
' TextBox1.Value = FRange.Offset(0, 1).Value
' TextBox2.Value = FRange.Offset(0, 2).Value
' End If

End With
Call wb.Close
Call ex.Application.Quit
End Sub