【Excel VBA】検索結果セルの行をリストボックスに表示させたい

VBA初心者です。sheet1に商品アンケート結果A列～AS列のデータがあります。
フォームにTextBox、ListBox1を配置しました。
TextBoxに「B列」の商品名（例："いちご"）を入力してEnterキー押下すると
"いちご"のレコードA列～AS列のデータをListBox1に表示させたいです。
検索結果の商品名のアドレス取得まではできましたが、A列～AS列すべてのデータをリストボックスに表示させるにはどのようにすれば良いでしょうか。宜しくお願い致します。


サンプルデータ：

　A列 　　　　　B列 　　　　C列 　　　　・・・・AS列
　住所 　　　　／商品名 　　　／種別　　　　　　／アンケート結果
●東京都 いちごミルク 飲料 　 ・・・・Ａ
●神奈川県 　 いちご 　　　　 果物 　 ・・・・Ａ
●千葉県 いちごチョコ 菓子 　 ・・・・Ａ
　群馬県 バナナチョコ 菓子 　 ・・・・Ｂ
TextBoxに"いちご"と入力した場合、●のレコードがすべてListBox1に表示させたいです。。


※コード※
Private Sub TextBox_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim Obj As Object
Dim wA1 As Variant
Dim wAddress As Variant
Dim wList As String
Dim ws1 As Worksheet

Set ws1 = Sheets("Sheet1") '元データ　商品アンケート

With ws1

'TextBox　検索
Set Obj = .Cells.Find( _
What:=TextBox.Value, _
LookIn:=xlValues, _
LookAt:=xlPart, _
MatchByte:=False)

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

'検索結果の最初のアドレスをセット
wA1 = Obj.Address

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

'検索結果セルの値を取得
wList = .Range(wAddress)

'ListBox1に追加
ListBox1.AddItem wList

'次の検索を行う
Set Obj = .Cells.FindNext(Obj)

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

No.7 ベストアンサー 回答者： jmuiny 回答日時： 2016/08/17 15:33

With ws1.Columns("B:B")

にした為A列が省かれてしまっていました。すみません。
紛らわしくなるので、修正したものを最初から全部書きます。

Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim Obj As Range
Dim wA1 As String
Dim wAddress As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet5")
With ws1
Set Obj = .Columns("B:B").Find(What:=TextBox1.Value, LookIn:=xlValues, LookAt:=xlPart, MatchByte:=False)
If Obj Is Nothing Then
MsgBox "対象データは存在しません。", _
vbOKOnly + vbInformation, "検索"
Exit Sub
End If
ListBox1.RowSource = ""
wA1 = Obj.Address
Do
Set wAddress = Obj.Offset(0, -1)
i = i + 1
.Range("A" & wAddress.Row & ":AS" & wAddress.Row).Copy Destination:=ws2.Range("A" & i)
Set Obj = .Columns("B:B").FindNext(Obj)
If Obj Is Nothing Then Exit Do
Loop Until Obj.Address = wA1
ListBox1.AddItem ""
ListBox1.List = ws2.Range("A1:AS" & i).Value
ws2.Range("A1:AS" & i).ClearContents
End With
End Sub

この回答へのお礼

ご回答いただき、有難うございます！
修正いただきました内容でリストボックスに検索結果を表示することができました！大変助かりました。有難うございます。

お礼日時：2016/08/17 15:53

No.6 回答者： jmuiny 回答日時： 2016/08/17 12:31

sheet1 とは別のシートを使う事により出来ましたので、一応紹介します。

Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim Obj As Range
Dim wA1 As String
Dim wAddress As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet5")
With ws1.Columns("B:B")
Set Obj = .Find(What:=TextBox1.Value, LookIn:=xlValues, LookAt:=xlPart, MatchByte:=False)
If Obj Is Nothing Then
MsgBox "対象データは存在しません。", _
vbOKOnly + vbInformation, "検索"
Exit Sub
End If
ListBox1.RowSource = ""
wA1 = Obj.Address
Do
Set wAddress = Obj.Offset(0, -1) '.Address
i = i + 1
.Range("A" & wAddress.Row & ":AS" & wAddress.Row).Copy Destination:=ws2.Range("A" & i)
Set Obj = .FindNext(Obj)
If Obj Is Nothing Then Exit Do
Loop Until Obj.Address = wA1
ListBox1.AddItem ""
ListBox1.List = ws2.Range("A1:AS" & i).Value
ws2.Range("A1:AS" & i).ClearContents
End With
End Sub

この回答へのお礼

ご回答いただき、有難うございます！
別シートを使う発想がなかったので、助かりました。
しかし、B列の商品名以降の列をws2(Sheet5)のA列～AS列にセットしているようで、元データのA列の住所データが入りません。。
Set wAddress = Obj.Offset(0, -1) で住所を取得しているように思えますが・・・。

お礼日時：2016/08/17 14:54

No.3 回答者： jmuiny 回答日時： 2016/08/17 09:05

昨日の回答でもリストの行を増やす処理が抜けていました。

申し訳ありません。

Dim i As Integer, j As Integer

'検索結果の最初のアドレスをセット
wA1 = Obj.Address
i = -1
Do
wAddress = Obj.Offset(0, -1).Address
i = i + 1
For j = 0 To 9 '44
ListBox1.AddItem ""
ListBox1.List(i, j) = .Range(wAddress).Offset(0, j)
Next j
'次の検索を行う

で10項目までは表示できました。

参考サイトなどで10項目以上をやってみようとしましたが、追加ができないようです。
必ず1行目になってしまいます、追加でやろうとするとエラーになります。
調べた範囲では、複数行で45項目を表示できているコードがありません。
引き続き時間があれば、調べてみますが、出来ないのかもしれませんね。

No.2 回答者： jmuiny 回答日時： 2016/08/16 18:25

論理上はリストボックスのColumnCountを45にして

wA1 = Obj.Address
Do
wAddress = Obj.Offset(0, -1).Address
For i = 0 To 45
ListBox1.AddItem ""
ListBox1.List(0, i) = .Range(wAddress).Offset(0, i)
Next i
'次の検索を行う
Set Obj = .Cells.FindNext(Obj)
'最初にヒットしたアドレスと同じ場合は処理を終了
If Obj.Address = wA1 Then Exit Do
Loop

とすればいいはずなのですが、J列まで表示した時点でエラーになります。
10列以上はエラーになる事がわかりました。
表示項目を10に絞るか、下記サイトを参考にして表示してみて下さい。
http://www.excel-wing.com/study/jitumu/1090

フォーム上のリストボックスに45項目も表示する必要があるのでしょうか。

この回答へのお礼

有難うございます！ご回答いただいたとおり、10列以上は表示されないことを確認しました。ご紹介いただいたサイトを参照し、45列表示できるようになりました！　
しかし、テキストボックスで”いちご”と入力すると、検索結果の最終行である”いちごチョコ”1件しかリストボックスに表示されなくなってしまいました。。どうすれば"いちごミルク"、"いちご"、"いちごチョコ"が表示されるようになるでしょうか。。

お礼日時：2016/08/16 21:31

No.1 回答者： hallo-2007 回答日時： 2016/08/16 17:21

>●のレコードがすべてListBox1に表示させたいです。

。
A～ASまですべてを表示ですか。

取りあえず、A列のみで説明すれば

'検索結果セルの値を取得
wList = .Range(wAddress)
を
'検索結果セルの値を取得
wList = .Range(wAddress).Offset(0,-1).Value
とかで、一度試してみて下さい。

それと
Set Obj = .Cells.Find( _
What:=TextBox.Value, _
LookIn:=xlValues, _
LookAt:=xlPart, _
MatchByte:=False)
も
Set Obj = .Columns("B:B").Find( _
What:=TextBox.Value, _
LookIn:=xlValues, _
LookAt:=xlPart, _
MatchByte:=False)
で十分ではないでしょうか。