エクセルで検索結果をユーザーフォームに表示したいのですが

質問

Ａ列　Ｂ列　Ｃ列　Ｄ列・・・Ｍ列
ＩＤ　名前　区分　日付・・・備考欄

　というようなデータで1000行以上になる予定で作っています。
　ユーザーフォーム上でＩＤを入力・検索した結果を同じフォーム内に表示させたいと思っています。
その際、
　(1)同じＩＤが何度も登録されている時もあるのですが、重複ＯＫですべてを表示させたい（スクロールバーなど使用したい）
　(2)列はＡ～ＭまであるのですがＡ・Ｂ・Ｄの３列のみをフォーム内に表示させたい
（もし可能なら、(3)同じ形式の複数シートからの検索結果をまとめて表示させる方法も教えて欲しいのですが）
　Excelに詳しい方、よろしくお願いします。

回答No.1

Wendy02 · ベストアンサー

こんばんは。

>重複ＯＫですべてを表示させたい

それは、配列変数に溜めていくぐらいしか思いつかないですね。

ユーザーフォームには、

検索入力用の、TextBox1 と　CommandButton1 と　ListBox1 を、それぞれひとつずつ用意します。
出力は、ListBox にします。フォントサイズは、適当に換えてください。標準では、かなり小さいです。

ListBox のプロパティの　ColumnCount は、2を入れてください。

後は、それなりに手を加えて、良いようにしてください。

'ユーザーフォームモジュール

'Option Explicit
Private i As Long
Private Sub CommandButton1_Click()
　Dim SearchText As String
　Dim PickUp()
　Dim sh As Worksheet
　SearchText = Me.TextBox1.Text
　If Me.TextBox1.Text = "" Then Exit Sub
　ReDim PickUp(1, 0)
　SearchFind ActiveSheet, SearchText, PickUp
　If MsgBox("他のシートも調べますか？", vbOKCancel) = vbOK Then

　　For Each sh In ThisWorkbook.Worksheets
　　　If Not sh Is ActiveSheet Then
　　　　SearchFind sh, SearchText, PickUp
　　　End If
　　Next sh
　End If
　Me.ListBox1.List = WorksheetFunction.Transpose(PickUp())
End Sub
Sub SearchFind(sh As Worksheet, _
　　　　　　　 SearchText As String, _
　　　　　　　 PickUp())
　Dim myAdd As String
　Dim c As Range

　Set c = sh.UsedRange.Columns(1).Find( _
　What:=SearchText, _
　LookIn:=xlValues, _
　LookAt:=xlWhole, _
　SearchOrder:=xlByColumns, _
　SearchDirection:=xlNext, _
　MatchByte:=True)
　If Not c Is Nothing Then
　　myAdd = c.Address
　　ReDim Preserve PickUp(1, i)
　　PickUp(0, i) = c.Offset(, 1).Value　'B列
　　PickUp(1, i) = c.Offset(, 3).Value　'D列
　　i = i + 1
　　Do
　　　Set c = sh.UsedRange.Columns(1).FindNext(c)
　　　ReDim Preserve PickUp(1, i)
　　　PickUp(0, i) = c.Offset(, 1).Value
　　　PickUp(1, i) = c.Offset(, 3).Value
　　　i = i + 1
　　Loop Until c Is Nothing Or c.Address = myAdd
　End If
End Sub

お礼

素早い回答ありがとうございます、おかげ様でかなり希望に近いものができそうです。
いろいろいじってみたのですが、わからない点があり教えていただけないでしょうか？
(4)抽出したデータが重複表示されてしまいます、2番目に抽出したデータがリストの最初と最後に出てくるのですが原因をつきとめられませんでした。
(5)抽出したリストを日付（Ｄ列）が新しい順に表示させたい。
お手数かけて申し訳ないのですが、よろしくお願いします。

回答No.2

Wendy02

こんばんは。Wendy02です。

(4)は、訂正しました。 (5) は、ソートプログラムをサブルーチンで追加してみました。
日付 は、一旦、シリアル値に戻されます。最初に見つかった書式に対して、出力は、すべてを統一して書式を変更します。

こちらで試した限りは、問題は解消されているように思いますが、試してみてください。

'ユーザーフォームモジュール

'Option Explicit
Private i As Long
Private rFormat As String
Private Sub CommandButton1_Click()
　Dim SearchText As String
　Dim PickUp()
　Dim sh As Worksheet
　SearchText = Me.TextBox1.Text
　If Me.TextBox1.Text = "" Then Exit Sub
　i = 0　'カウントの初期化
　rFormat = "" 'セルの書式の初期化
　ReDim PickUp(1, 0)
　SearchFind ActiveSheet, SearchText, PickUp
　If MsgBox("他のシートも調べますか？", vbOKCancel) = vbOK Then
　　For Each sh In ThisWorkbook.Worksheets
　　　If Not sh Is ActiveSheet Then
　　　　SearchFind sh, SearchText, PickUp
　　　End If
　　Next sh
　End If
　　BSort PickUp, rFormat '並べ替えサブルーチン
　Me.ListBox1.List = WorksheetFunction.Transpose(PickUp())
End Sub

Sub SearchFind(sh As Worksheet, _
　　　　　　　 SearchText As String, _
　　　　　　　 PickUp())
　Dim myAdd As String
　Dim c As Range

　Set c = sh.UsedRange.Columns(1).Find( _
　What:=SearchText, _
　LookIn:=xlValues, _
　LookAt:=xlWhole, _
　SearchOrder:=xlByColumns, _
　SearchDirection:=xlNext, _
　MatchByte:=True)
　If Not c Is Nothing Then
　　myAdd = c.Address
　　ReDim Preserve PickUp(1, i)
　　PickUp(0, i) = c.Offset(, 1).Value 'B列
　　PickUp(1, i) = c.Offset(, 3).Value2 'D列 シリアル値の格納
　　If rFormat = "" Then rFormat = c.Offset(, 3).NumberFormatLocal
　　i = i + 1
　　Do
　　　Set c = sh.UsedRange.Columns(1).FindNext(c)
　　　If c.Address = myAdd Then Exit Sub
　　　ReDim Preserve PickUp(1, i)
　　　PickUp(0, i) = c.Offset(, 1).Value　'B列
　　　PickUp(1, i) = c.Offset(, 3).Value2　'D列 シリアル値の格納
　　　i = i + 1
　　Loop Until c Is Nothing
　End If
End Sub

Private Sub BSort(ar() As Variant, Optional dtFormat As String)
'バブルソート/ar() 二次元配列, dtFormat 日付書式
　Dim u As Long
　Dim i As Long
　Dim j As Long
　Dim k As Long
　Dim t1 As Variant
　Dim t2 As Variant
　u = UBound(ar(), 2)
　i = LBound(ar(), 2)
　Do While i < u
　　j = u
　　Do While j > i
　　　If ar(1, j) < ar(1, i) Then '昇順
　　　　t1 = ar(0, j)
　　　　t2 = ar(1, j)
　　　　ar(0, j) = ar(0, i)
　　　　ar(1, j) = ar(1, i)
　　　　ar(0, i) = t1
　　　　ar(1, i) = t2
　　　End If
　　　j = j - 1
　　Loop
　　i = i + 1
　Loop
'Option
　For k = LBound(ar(), 2) To UBound(ar(), 2)　'書式戻し
　ar(1, k) = Format$(ar(1, k), dtFormat)
　Next k
End Sub

お礼

ありがとうございます、おかげ様で無事に解決しました。
今まで配列にほとんど触れなかったのでいい勉強になりました。
今回訂正していただいたコードで、検索結果が一つしかなかった場合にTransposeがうまくはたらかず（？）結果（B・D列）が縦に表示されてしまいました。
そこで１日悩んで
ReDim Preserve PickUp(1, i)
の一文を Me.ListBox1.List ・・・の前に入れてみました、今のところ順調のようです。

どうもありがとうございました!!