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

Question

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

jmuiny · Accepted Answer

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

hallo-2007 · Answer

>●のレコードがすべて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)
で十分ではないでしょうか。

jmuiny · Answer

論理上はリストボックスの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項目も表示する必要があるのでしょうか。

jmuiny · Answer

昨日の回答でもリストの行を増やす処理が抜けていました。申し訳ありません。

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項目を表示できているコードがありません。
引き続き時間があれば、調べてみますが、出来ないのかもしれませんね。

jmuiny · Answer

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

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

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

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

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

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

With ws1.Columns("B:B")

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング