エクセルVBA 複数列のリストボックス内を検索して値を複数列表示したい

複数列表示したリストボックス内を絞り込み検索して絞り込み値も検索前と同様の複数列で表示することはできますか？

現場一覧シートのA列に現場名、K列に住所があります。（現場名は増え続けます）
別シートのセルをダブルクリックするとリストボックスを出します。（コード添付なし）
リストボックス内の絞り込み検索後に現場名をダブルクリックすると、アクティブセルに現場名と右隣に住所を表示するようにしたいです。
AddItemの複数列表示の使い方がよく理解できてない気がします。
添付写真は現場名30で絞り込み検索していますが住所列が表示されていません。絞り込み検索後に現場名と住所を表示する方法が分からずに困っております。

もし、リストボックスに複数列表示しなくても現場名ダブルクリック後にアクティブセルに現場名表示、連動して右隣セルに住所を表示が可能であればそれでも解決となります。

VBAをネットで勉強して3ヵ月たちます。
ネット上のコードを参考にして何とか他のブックは仕事で使えるVBAを組み立てましたが、これだけは記述方法が分かりません。
どうかご教授ください。

'*****************************************************
'検索フォームを開いた時の処理
'*****************************************************
Private Sub UserForm_Initialize()
Dim wLastGyou As Long

'最終行番号を取得
wLastGyou = Worksheets("現場一覧").UsedRange.Rows.Count

'リストボックスに「現場一覧」のリストをセット
With lstGenba

'列の指定：11列とする
.ColumnCount = 11

'列幅11列を2列表示にする
.ColumnWidths = "130;0;0;0;0;0;0;0;0;0;100"

'見出しの設定：無し
.ColumnHeads = False

'リストボックスの値にセルA2からK最終行までセット
.RowSource = "現場一覧!A2:k" & wLastGyou

End With

End Sub
'*****************************************************
'検索用のテキストボックス更新後の処理
'*****************************************************
Private Sub txbSerch_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim Obj As Object
Dim wAddST As Variant
Dim wAddress As Variant
Dim wKamoku As Variant
Dim wLastGyou As Long

'最終行番号を取得
wLastGyou = Worksheets("現場一覧").UsedRange.Rows.Count

With Worksheets("現場一覧")

'テキストボックスの値が含まれるセルを検索
Set Obj = Range("現場一覧!A2:K" & wLastGyou).Find( _
What:=txbSerch.Value, _
LookIn:=xlValues, _
lookat:=xlPart, _
MatchByte:=False)

'検索対象がない場合はメッセージを表示
If Obj Is Nothing Then
MsgBox "現場名は存在しません。", _
vbOKOnly + vbInformation, "検索"
Else
'リストボックスをクリア
lstGenba.RowSource = ""

'検索にヒットした先頭のセルのアドレスをセット
wAddST = Obj.Address

'検索の繰り返し処理
Do
'検索にヒットしたセルのアドレスをセット
wAddress = Obj.Address

'検索にヒットしたセルの値を取得
wKamoku = .Range(wAddress).Value

'リストボックスに追加
lstGenba.AddItem wKamoku

'次の検索を行う
Set Obj = Range("現場一覧!A2:A" & wLastGyou).FindNext(Obj)

'最初にヒットしたアドレスと同じ場合は処理を終了
If Obj.Address = wAddST Then Exit Do
Loop
End If
End With
End Sub

'*****************************************************
'リストボックスをダブルクリックした時の処理
'*****************************************************
Private Sub lstGenba_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim wSheetName As Variant

'アクティブなシート名を取得
wSheetName = ActiveSheet.Name

'アクティブなセルにリストボックスの値をセット
With Worksheets(wSheetName)
.Cells(ActiveCell.Row, ActiveCell.Column).Value = lstGenba.List(lstGenba.ListIndex, 0)
.ActiveCell.Offset(0, 1).Value = lstGenba.List(lstGenba.ListIndex, 10)
End With
'フォームを終了する
Unload Me
End Sub

No.1 ベストアンサー 回答者： kito2015 回答日時： 2015/05/18 19:10

一例です。

'*****************************************************
'検索用のテキストボックス更新後の処理
'*****************************************************
Private Sub txbSerch_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim Obj As Object
Dim wAddST As Variant
Dim wAddress As Variant
Dim wKamoku As Variant
Dim wLastGyou As Long

'---追加箇所--------------------------------------
Dim i As Long
'リスト表示１１項目→３項目（現場名、空白、住所1）
lstGenba.ColumnCount = 3
lstGenba.ColumnWidths = "130;10;100"
'--------------------------------------------------

'最終行番号を取得
wLastGyou = Worksheets("現場一覧").UsedRange.Rows.Count

With Worksheets("現場一覧")

'テキストボックスの値が含まれるセルを検索
Set Obj = Range("現場一覧!A2:K" & wLastGyou).Find( _
What:=txbSerch.Value, _
LookIn:=xlValues, _
lookat:=xlPart, _
MatchByte:=False)

'検索対象がない場合はメッセージを表示
If Obj Is Nothing Then
MsgBox "現場名は存在しません。", _
vbOKOnly + vbInformation, "検索"
Else
'リストボックスをクリア
lstGenba.RowSource = ""

'検索にヒットした先頭のセルのアドレスをセット
wAddST = Obj.Address

'検索の繰り返し処理
Do
'検索にヒットしたセルのアドレスをセット
wAddress = Obj.Address

'--------変更箇所---------------------------------------
i = Obj.Row
'検索にヒットしたセルの値を取得とリストボックスに追加
lstGenba.AddItem .Cells(i, 1)
lstGenba.List(lstGenba.ListCount - 1, 1) = ""
lstGenba.List(lstGenba.ListCount - 1, 2) = .Cells(i, 11)
'--------------------------------------------------------

''検索にヒットしたセルの値を取得
'wKamoku = .Range(wAddress).Value
'
''リストボックスに追加
'lstGenba.AddItem wKamoku

'次の検索を行う
Set Obj = Range("現場一覧!A2:A" & wLastGyou).FindNext(Obj)

'最初にヒットしたアドレスと同じ場合は処理を終了
If Obj.Address = wAddST Then Exit Do
Loop
End If
End With
End Sub

'*****************************************************
'リストボックスをダブルクリックした時の処理
'*****************************************************
Private Sub lstGenba_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim wSheetName As Variant

'アクティブなシート名を取得
wSheetName = ActiveSheet.Name

'--------------変更箇所-----------------------------------------------
'アクティブなセルにリストボックスの値をセット
With Worksheets(wSheetName)
.Cells(ActiveCell.Row, ActiveCell.Column).Value = lstGenba.List(lstGenba.ListIndex, 0)
.Cells(ActiveCell.Row, ActiveCell.Column + 1).Value = lstGenba.List(lstGenba.ListIndex, 2)
End With
'--------------------------------------------------------------------------

'アクティブなセルにリストボックスの値をセット
'With Worksheets(wSheetName)
'.Cells(ActiveCell.Row, ActiveCell.Column).Value = lstGenba.List(lstGenba.ListIndex, 0)
'.ActiveCell.Offset(0, 1).Value = lstGenba.List(lstGenba.ListIndex, 10)
'End With
'フォームを終了する
Unload Me
End Sub

この回答へのお礼

ありがとうございます。
思うように動きました！
まだ完全に理解できてませんので勉強しようと思います。
もう諦めかけていたところに教えて頂いて本当に感謝しています！

お礼日時：2015/05/19 16:59