エクセル2007VBAで検索するコードを知りたい。

質問

エクセル2007(Excel2007)のVBAで【検索と置換】と同等の機能をもった検索アプリケーションを作りたいのですが、
そのコード(コマンドボタンを実行したときのコード)を教えていただけないでしょうか。
(おそらくですが、リストボックスのコードも必要だと思います。)

正しくは、【検索と置換】から【置換】機能を無くしたものとイメージしていただきたいです。

●設置するもの
ユーザーフォーム(UserForm1)
テキストボックス(TextBox1)
コマンドボタン(CommandButton1)
リストボックス(ListBox1)

●仕様
ユーザーフォームのテキストボックスに入力してコマンドボタンを押すと、検索対象を見つけ、
リストボックスにその対象一覧を行ごとに表示するものになります。

●検索するときの条件
(1)大文字と小文字を区別しない
(2)半角と全角を区別しない
(3)部分一致すれば(一部でも一致すれば)検索対象にする
(4)今、開いているワークシート上の「全てのセルが検索対象(列や行を指定しない)」

※検索されたセルの存在する行ごとに、ユーザーフォームのリストボックスに(1行ずつ)表示したいです。
そして、リストボックスに表示されたデータのうち、どれか1つを選ぶと、その選択対象の行の【D列】にアクティブセルを移動するようにしたいです(画面もアクティブセルが見える位置にスクロールします)。

●リストボックスに(1行ごとに)表示するもの●
↓↓↓
(左から)I列の値、D列の値、O列の値、Q列の値(→4列の値になります)

※リストボックスにQ列の値が表示された場合のみ(Q列に何かしらのデータがある場合のみ)、
リストボックス上の【その行の(I列の値、D列の値、O列の値、Q列の値の)文字すべてを赤色】にして表示していただきたいです。

分かる方がいましたらよろしくお願いいたします。

回答No.7

eden3616 · ベストアンサー

【2/3回答】

No.6のコードの続きに記述願います。

////////////ＶＢＡコード(2)////////////

'▼検索ボタンクリック時
Private Sub CommandButton1_Click()
'宣言
　　Dim key As String, myCol As Variant, Colcnt As Integer
　　Dim hit As Range, bk_hit As String
　　Dim data() As String, flag As Boolean
　　Dim cnt As Long, i As Long, frm As String
　　Dim myRng As Range, tarRng As Range
　　Dim myLabel As Variant, label_w As Variant

'準備
　　'リストビューに表示する列を設定
　　myCol = Split("I,D,O,Q", ",")
　　'ラベルに表示する文字列を設定
　　myLabel = Split("行番号,項目1,項目2,項目3,項目4", ",") '1つ目は検索行番号の列見出し名を指定
　　Colcnt = UBound(myCol) + 1
　　'列幅を設定
　　label_w = Split("0,50,70,90,110", ",") '省略不可、1つ目は行番号の列幅で非表示の場合は0を設定
　　'検索値を格納・スペースの削除
　　key = Me.TextBox1.Value
　　key = Replace(Replace(WorksheetFunction.Trim(key), "　", " "), " ", "")
　　'空白を除外してテキストボックスに反映
　　Me.TextBox1.Value = key '不要であれば削除してください
　　If Len(key) = 0 Then
　　　　MsgBox "検索値を入力してください。"
　　　　Exit Sub
　　End If
　　'検索対象を格納
　　Set tarRng = Cells
　　'Set tarRng = Range("D:D") '特定列を検索する場合コメントアウト
　　'検索基点を格納
　　Set myRng = tarRng.Cells(tarRng.Rows.Count, tarRng.Columns.Count)
　　'検索値,A1セル,値,部分一致,行方向,順方向,大/小文字区別無し,半/全角区別無しで検索
　　Set hit = tarRng.Find( _
　　　　What:=key, _
　　　　After:=myRng, _
　　　　LookIn:=xlValues, _
　　　　LookAt:=xlPart, _
　　　　SearchOrder:=xlByRows, _
　　　　SearchDirection:=xlNext, _
　　　　MatchCase:=False, _
　　　　MatchByte:=False)
　　'検索が見つからなかった時の処理
　　If hit Is Nothing Then
　　　　MsgBox """" & key & """が見つかりません"
　　　　Exit Sub
　　End If
　　bk_hit = hit.Address
　　ReDim data(Colcnt, 1)

'繰り返し検索処理
　　Do
　　　　'データ格納
　　　　If flag Then
　　　　　　flag = False
　　　　Else
　　　　　　data(0, cnt) = hit.Row
　　　　　　For i = 0 To UBound(myCol)
　　　　　　　　data(i + 1, cnt) = Cells(hit.Row, myCol(i)).Value
　　　　　　Next i
　　　　End If
　　　　'次検索
　　　　Set hit = tarRng.FindNext(hit)
　　　　'既一致チェック
　　　　If Application.Intersect(hit, myRng) Is Nothing Then
　　　　　　If myRng Is Nothing Then
　　　　　　　　Set myRng = Rows(hit.Row)
　　　　　　Else
　　　　　　　　Set myRng = Union(myRng, Rows(hit.Row))
　　　　　　End If
　　　　Else
　　　　　　flag = True
　　　　End If
　　　　'判定処理
　　　　If flag = False Then
　　　　　　cnt = cnt + 1
　　　　　　ReDim Preserve data(Colcnt, cnt + 1)
　　　　End If
　　Loop Until hit.Address = bk_hit

'リストビュー表示
　　With Me.ListView1
　　　　.ListItems.Clear
　　　　.ColumnHeaders.Clear
　　　　'初期化
　　　　.View = lvwReport　　　　 '外観表示指定
　　　　.LabelEdit = lvwManual　　 '左端項目の編集設定
　　　　.HideSelection = False　　 'フォーカス移動時の選択解除設定
　　　　.AllowColumnReorder = True '列幅の変更有無
　　　　.FullRowSelect = True　　 '行全体を選択有無
　　　　.Gridlines = True　　　　 'グリッド線表示有無
　　　　'列見出し作成
　　　　If UBound(myLabel) = -1 Then
　　　　　　.ColumnHeaders.Add , , "列番号", CInt(label_w(0))
　　　　Else
　　　　　　.ColumnHeaders.Add , , myLabel(0), CInt(label_w(0))
　　　　End If
　　　　If UBound(myCol) = UBound(myLabel) - 1 Then
　　　　　　For i = 0 To UBound(myLabel) - 1
　　　　　　　　.ColumnHeaders.Add , , myLabel(i + 1), CInt(label_w(i + 1))
　　　　　　Next
　　　　Else
　　　　　　For i = 0 To UBound(myCol)
　　　　　　　　.ColumnHeaders.Add , , myCol(i) & "列", CInt(label_w(i + 1))
　　　　　　Next
　　　　End If
　　　　'行番号の桁表示様式作成
　　　　frm = WorksheetFunction.Rept("0", Len(CStr(data(0, cnt - 1))))
　　　　'データ登録
　　　　For cnt = 0 To UBound(data, 2) - 2
　　　　　　With .ListItems.Add
　　　　　　　　'行番号登録
　　　　　　　　.Text = Format(data(0, cnt), frm)
　　　　　　　　'4番目の要素が空白以外なら着色
　　　　　　　　If Len(data(4, cnt)) > 0 Then
　　　　　　　　　　.ForeColor = RGB(255, 0, 0)
　　　　　　　　End If
　　　　　　　　'指定列項目登録
　　　　　　　　For i = 1 To UBound(myCol) + 1
　　　　　　　　　　.SubItems(i) = data(i, cnt)
　　　　　　　　　　'4番目の要素が空白以外なら着色
　　　　　　　　　　If Len(data(4, cnt)) > 0 Then
　　　　　　　　　　　　.ListSubItems(i).ForeColor = RGB(255, 0, 0)
　　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　End With
　　　　Next cnt
　　End With
End Sub

お礼

eden3616さん
ありがとうございます。

質問に対するアンサーとして、一番キモとなる検索部分を担うコードでしたので
回答No.7をベストアンサーとさせていただきました。

この度は、本当にたくさんお世話になりました。

今後とも、もし見かける機会がございましたらどうぞよろしくお願いいたします。
ありがとうございました。

回答No.9

eden3616

No8の解説にて訂正があります。

No8の解説を記述した後に、No6、7のコードを修正したため
下記2箇所に置きまして解説の中で引用しているコードと実際に記述してあるコードが異なっております。
解説中だけですので、NO6、7のVBAコードを使用して頂ければ問題ありませんが、解説と一部異なるコードになっておりますので混乱される要因となる回答になった事、申し訳ありません。

以下の通り訂正致します。

■No.8（1）の解説内
全角スペースの削除に対応できていなかったため修正しております。

key = Replace(WorksheetFunction.Trim(key), " ", "")
　　　　　↓
key = Replace(Replace(WorksheetFunction.Trim(key), "　", " "), " ", "")

■No.8（2）の解説内
処理的なコードは同じですが、設定している値が異なっております。

label_w = Split("0,10,20,30,40", ",") '省略不可、1つ目は行番号の列幅で非表示の場合は0を設定
　　　　　↓
label_w = Split("0,50,70,90,110", ",") '省略不可、1つ目は行番号の列幅で非表示の場合は0を設定

お礼

eden3616さん、
私のワガママに多くの時間を割いていただきましてありがとうございます。

変更点にも迅速に対応していただきまして
まさに理想とする検索ツールが出来上がりました。
とても嬉しく思います。

また、
おっしゃる通り、ユーザーフォームのサイズ変更などは本来の質問の趣旨とはズレる部分でしたのに、こんなに手間の要するコードを考えて下さり感謝しております。(添付画像への文字入れなど、たいへんお手数おかけしました。とても分かりやすいですね。)

なにより、私のようなVBAに詳しくない者でも、コードの隣にコメントを書いて頂いたおかげで編集して応用できるのがとても助かりました。
訂正箇所への配慮なども含めまして、ただただ感謝でございます。

回答No.8

eden3616

【3/3回答】

No6、7のコードに関する補足・説明になります。

下記の(3)については本件とは直接関係していないため、VBAにおけるフォームの
コントロール配置に関する新たな質問を揚げられたほうが良いかと思います。
　　（ですが、一応実装はしております。）

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～

(1)テキストボックスにスペースだけ入力した場合も、メッセージを表示
　　（スペースの数や半角全角のスペース問わず）

以下の箇所にて対応しました。
添付画像では「　　　　Ｄ　　　　10 」で検索しています。
複数の空白が入力されている、または検索値の間や前後に空白が複数ある場合に全ての空白を削除します。
現在は削除した検索値でテキストボックスの値を置き換えています。
（不要であれば最下行を削除してください）

　　'検索値を格納・スペースの削除
　　key = Me.TextBox1.Value
　　key = Replace(WorksheetFunction.Trim(key), " ", "")
　　'空白を除外してテキストボックスに反映
　　Me.TextBox1.Value = key '不要であれば削除してください

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～

(2)リストビューの幅をデフォルトで調整、又は前回閉じた幅のまま記憶

以下の箇所で列幅（固定値）を設定できるように修正しました。
このコードでは以前の状態（等幅設定）にはできませんので値は全て設定してください。
（1つ目の「0」は検索行番号の列幅になりますので、非表示の場合は0にしてください）

　　'列幅を設定
　　label_w = Split("0,10,20,30,40", ",") '省略不可、1つ目は行番号の列幅で非表示の場合は0を設定

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～

(3)ユーザーフォームのサイズを手動で変える仕様

ExcelVBAの標準機能では利用できないため、Windows APIにて実装する必要があります。
以下参考サイト様より、「Windows API宣言」及び「FormSetting」プロシージャのコードをそのまま流用しております。

参考サイト：
http://propg.ee-mall.info/%E3%83%97%E3%83%AD%E3%82%B0%E3%83%A9%E3%83%9F%E3%83%B3%E3%82%B0/vba/%E3%80%8Cexcel-vba-%E3%83%A6%E3%83%BC%E3%82%B6%E3%83%BC%E3%83%95%E3%82%A9%E3%83%BC%E3%83%A0%E3%82%92%E3%83%AA%E3%82%B5%E3%82%A4%E3%82%BA%E5%8F%AF%E8%83%BD%E3%81%AB%E3%81%99%E3%82%8B/

現在使用しているコントロールの初期配置（パラメータ）は以下の通りです

▼ユーザーフォーム本体の幅と高さ
①UseroForm1.width = 370
②UseroForm1.height = 185
▼テキストボックスの幅
　TextBox1.left = 5
　TextBox1.top = 10
③TextBox1.width = 295
　TextBox1.height = 18
▼コマンドボタンの左位置
④CommandButton1.left = 305
　CommandButton1.top = 10
　CommandButton1.width = 50
　CommandButton1.height = 18
▼リストビューの幅と高さ
　ListView1.left = 5
　ListView1.top = 35
⑤ListView1.width = 354
⑥ListView1.height = 126

※以下の計算で必要なパラメータに番号を付けています。

VBAにはフォーム変更に追従するパラメータ設定がありませんので、
ユーザーフォームのサイズが変更された際に実行されるイベント
「UserForm_Resize」にて各コントロールの位置を再配置しています。

コントロールの再配置をしている箇所は下記のコードになります。
①～⑥の初期値と、ユーザーフォームの幅=UFwと高さ=UFhの値より
相対的に数値を計算して設定する必要があります。

適応されているWindowsのテーマにおいて計算値にズレが生じますので、
各計算値には調整値として+10しております。環境に合わせて微調整願います。
（私はWindows7、Office2007環境にて作成しています）

'▼フォームオブジェクトの追従処理
Private Sub UserForm_Resize()
　　Dim UFw As Integer
　　Dim UFh As Integer
　　'UserForm1の幅・高さを格納
　　UFw = Me.Width
　　UFh = Me.Height
　　'テキストボックスの配置
　　With Me.TextBox1
　　　　.Width = UFw - (370 - 295 + 10) '幅の変更：UFw - (① - ③ + 調整値)
　　End With
　　'ボタンの配置
　　With Me.CommandButton1
　　　　.Left = UFw - (370 - 305 + 10) '左位置の変更：UFw - (① - ④ + 調整値)
　　End With
　　'リストビューの配置
　　With Me.ListView1
　　　　.Width = UFw - (370 - 354 + 10) '幅の変更：UFw - (① - ⑤ + 調整値)
　　　　'0未満の数値をパラメータに与えるとエラーが発生するため判定
　　　　If UFh - (185 - 126 + 10) > 0 Then
　　　　　　.Height = UFh - (185 - 126 + 10) '高さの変更：UFh - (② - ⑥ + 調整値)
　　　　End If
　　End With
End Sub

コントロールの位置設定など細かい設定については調整し出すときりがないと思いますので、この程度まで。
上記回答を参考にご自身でいろいろ調べてみてください。

回答No.6

eden3616

【1/3回答】

コードが長くなりましたので3分割しての回答になります。
ご了承ください。

フォームモジュールに「ＶＢＡコード(1)」（この回答：1/3）と
「ＶＢＡコード(2)」（次の回答：2/3）を順番に記述してください。
前回同様、標準モジュールは変更ありません。

最後の回答：3/3にて補足・解説致します。

////////////ＶＢＡコード(1)////////////

'■フォームモジュール(UserForm1)に記述
'Windows API宣言
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME = &H40000
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

'▼フォームのリサイズ設定
Private Sub UserForm_Activate()
　　Call FormSetting
End Sub
Public Sub FormSetting()
　　Dim result As Long
　　Dim hwnd As Long
　　Dim Wnd_STYLE As Long
　　hwnd = GetActiveWindow()
　　Wnd_STYLE = GetWindowLong(hwnd, GWL_STYLE)
　　Wnd_STYLE = Wnd_STYLE Or WS_THICKFRAME Or &H30000
　　result = SetWindowLong(hwnd, GWL_STYLE, Wnd_STYLE)
　　result = DrawMenuBar(hwnd)
End Sub

'▼フォームオブジェクトの追従処理
Private Sub UserForm_Resize()
　　Dim UFw As Integer
　　Dim UFh As Integer
　　'UserForm1の幅・高さを格納
　　UFw = Me.Width
　　UFh = Me.Height
　　'テキストボックスの配置
　　With Me.TextBox1
　　　　.Width = UFw - (370 - 295 + 10) '幅の変更：UFw - (① - ③ + 調整値)
　　End With
　　'ボタンの配置
　　With Me.CommandButton1
　　　　.Left = UFw - (370 - 305 + 10) '左位置の変更：UFw - (① - ④ + 調整値)
　　End With
　　'リストビューの配置
　　With Me.ListView1
　　　　.Width = UFw - (370 - 354 + 10) '幅の変更：UFw - (① - ⑤ + 調整値)
　　　　'0未満の数値をパラメータに与えるとエラーが発生するため判定
　　　　If UFh - (185 - 126 + 10) > 0 Then
　　　　　　.Height = UFh - (185 - 126 + 10) '高さの変更：UFh - (② - ⑥ + 調整値)
　　　　End If
　　End With
End Sub

'▼リストビュー選択時
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
　　Cells(CLng(Item), "D").Select
End Sub

'▼リストビュー列見出しクリックソート(不要であれば削除)
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
　　With ListView1
　　　　.SortKey = ColumnHeader.Index - 1
　　　　.SortOrder = .SortOrder Xor lvwDescending
　　　　.Sorted = True
　　End With
End Sub

回答No.5

eden3616

No4のコードに対する解説及び補足への対応になります。

今回のコードでは以下の対応を行っています。
速度的にまだ遅いようであれば補足願います。

～～～～～～～～～～～～～～～～～～～～～～～～～～～～

>実際に試させていただきまして、
>自分のパソコン環境(スペック)などから、どうしても動作が少々遅くなってしまうことがわかりました。
>(エクセル自体、数千行という膨大なデータがあるため、遅くなってしまうのは致し方ないのですが。)

やはりFind検索は遅いですね。対象データのボリュームにもよりますが、
こちらでA～Q列の1万行(添付画像)で試したところ「A」で検索した場合30秒弱かかりました。
今回のコードも同じFind検索ですが、既に検索された行か調べる方法を変えたため
同じデータで1/6程度の5秒で完了するようになりました。

～～～～～～～～～～～～～～～～～～～～～～～～～～～～

>そこで大変お手数おかけしますが、もっとも頻繁に検索するD列のみを検索するようにしたら
>動作が速くなるのでは?と考えまして、
>以下の条件に変更したコードを教えていただけないでしょうか。
>●検索するときの条件
>(4)今、開いているワークシート上の「すべてのD列セルのみを検索対象にする」

コード内前半の「'検索対象を格納」でコメントアウトしている部分を外してください。
対象のセル範囲に対して検索を行います。
（現在はNo2と同様に全セルを対象としております）
　(1)　Cells：全対象を検索
　(2)　Range("D:D")：D列を検索
　(3)　Range("D1:D100")：D1：D100を検索
私の環境では上記(1)及び(2)ではどちらも5秒程度で速度に違いはありませんでした。
(3)については範囲を限定的にすることで相対的に早くなります。

～～～～～～～～～～～～～～～～～～～～～～～～～～～～

>また、仕様上、B列にExcelの行番号とは別の番号を表示しているため、
>見間違いをなくすため、行番号・列番号の見出しを非表示にしていることもありまして、
>リストビュー上の【１項目目の行番号】を非表示にしていただく(無くす)ことは可能でしょうか。
>(利便性を視野に入れた配慮に反する注文になってしまい、本当に申し訳ございません。)

再選択において再度対象のセルを記憶しておく必要がありますので今回行版行を書出しています。
完全に無くす場合は配列に書出す、保持用のリストボックスを用意する、セルに書出す等する必要があります。
（またその場合、下記の列見出しのソート機能は使えなくなるでしょうが）
見た目上、見えなくするだけでよろしければ以下のように1項目目の列幅を0にすることで隠すことが出来ます。

　　'列見出し作成
　　If UBound(myLabel) = -1 Then
　　　　.ColumnHeaders.Add , , "列番号", 0 '最後の引数(数値)が列幅
　　Else
　　　　.ColumnHeaders.Add , , myLabel(0), 0 '最後の引数(数値)が列幅
　　End If

また、余計な事ではあるのですが・・・
列見出しをクリックすることで該当項目をキーとしたソートが出来ます。
Q列の見出しをクリックすることで、赤文字だけを固めてソート等できますので利用用途によっては便利になるのではないでしょうか？
行番号の列見出しは隠れているだけですので、マウスカーソルにより「行番号」の見出し幅を増やせば表示されます。
1項目目の「行番号」列見出しをクリックで元の並びになるように桁数合わせをしています。

～～～～～～～～～～～～～～～～～～～～～～～～～～～～

その他の変更点ですが・・・・

(1)列見出しの表示名を設定出来ます
　・「'ラベルに表示する文字列を設定」の箇所で設定してください。
　・ラベル指定部分を空欄「myLabel = Split("", ",")」にするとNo2の表示になります。

(2)表示項目数を変更（増加）できます
　・「'リストビューに表示する列を設定」の列記号をカンマで区切り変更してください。
　・対応する「'ラベルに表示する文字列を設定」も同様に変更してください。
　　例）A列を項目5として追加
　　　　myCol = Split("I,D,O,Q,A", ",")
　　　　myLabel = Split("行番号,項目1,項目2,項目3,項目4,項目5", ",")

(3)気づいたバグを修正しました
　・テキストボックスが空白の場合にメッセージ表示で終了
　・対象データが32767行を超えるとオーバーフローするエラーを修正

補足：また、検索値にはワイルドカードを使用した検索が可能です。
　　（検索値を"D*01"で"D101"や"D2101"などの行が検索されます）

補足

eden3616さん、
大変お世話になっております。

お返事が遅れてしまいまして、申し訳ありません。

この度も
ご丁寧に教えて下さり、ありがとうございます。

-------------------------------------------------
'検索対象を格納
　　Set tarRng = Cells
　　'Set tarRng = Range("D:D") '特定列を検索する場合コメントアウト

↑↑
おっしゃる通りに、コメントアウトしてD列のみの検索に変更したところ
【Set tarRng = Range("D:D")】で
劇的に動作が速くなりました。ありがとうございます。

2500行くらいですと、1秒もかからないくらいでとても驚いております!
感謝いたします。

-------------------------------------------------
リストビュー上の【１項目目の行番号】を非表示についても配慮していただきまして、ありがとうございます。
おっしゃる通り、見た目上のみ、見えなくする仕様を望んでいましたので大満足です。

-------------------------------------------------
【Q列の見出しをクリックすることで、赤文字だけを固めてソート等できます】
↑↑
これはものすごい便利ですね！個人的に、作業効率が何倍になるか分からないくらいに便利な機能です。
ありがとうございます、の一言に尽きます。

-------------------------------------------------
また、先に起こる得るエラーについてもあらかじめ考えてくださり、とても助かります。

列見出しの表示や数を変更する方法も非常にありがたいです。
いずれは少し変更したいときが来ると思っていましたので。
-------------------------------------------------

*************************************************
ここからは、
使わせていただいて、個人的に、こうするとさらに便利に(効率的に)なると思ったことが3つ見つかりましたので、
僭越ながら書かせていただきたいです。

(1)テキストボックスにスペース(目に見える文字列は一文字もない状態です。)だけ入力した場合も、
【検索値を入力してください。】のウインドウを表示するようにしていただけますと幸いです。

※また、スペースの数や半角全角のスペース問わずに、
【検索値を入力してください。】のウインドウを出していただけたら、とても助かります。

(2)【リストビューに表示する列】の(横)幅をデフォルト(標準仕様)で調整することはできるのでしょうか?

あるいは、前回閉じた幅のまま記憶しておく、ということができればとても便利だと思いました。
どちらか1つが出来るのならば、その方法を教えていただきたいです。

(3)ユーザーフォームのサイズを手動で変える仕様にすることはできるでしょうか?
(枠と言いますが、端っこにマウスを当てると矢印が出てサイズ変更できるイメージです。)

と言いますのも、リストビューに表示される結果(行数)が増えますと下に長くなりますので
スクロールする必要が出てきます。

そんなときに、サイズ変更でユーザーフォーム自体を下に長くできれば(一気に見れるデータの行数が増えますので、)
スクロールするより楽だと思ったもので。

もし、可能ということであれば大変お手数おかけしますが、ご教授願いたいです。

回答No.4

eden3616

回答が長くなったので分割致します。
次の回答でコードの変更内容と補足への返答を致します。
最下のVBAコードと、フォームモジュール（UserForm1）のコードを全て差し換えてください。
標準モジュールは、ただフォームを表示させるためのものですので変更がありません。

//////////////////////VBAコード//////////////////////

'■フォームモジュール(UserForm1)に記述

'▼検索ボタンクリック時
Private Sub CommandButton1_Click()

'宣言
　　Dim key As String, myCol As Variant, Colcnt As Integer
　　Dim hit As Range, bk_hit As String
　　Dim data() As String, flag As Boolean
　　Dim cnt As Long, i As Long, frm As String
　　Dim myRng As Range, tarRng As Range
　　Dim myLabel As Variant

'準備
　　'リストビューに表示する列を設定
　　myCol = Split("I,D,O,Q", ",")
　　'ラベルに表示する文字列を設定
　　myLabel = Split("行番号,項目1,項目2,項目3,項目4", ",") '1つ目は検索行番号の列見出し名を指定
　　Colcnt = UBound(myCol) + 1
　　'検索値を格納
　　key = Me.TextBox1.Value
　　If Len(key) = 0 Then
　　　　MsgBox "検索値を入力してください。"
　　　　Exit Sub
　　End If
　　'検索対象を格納
　　Set tarRng = Cells
　　'Set tarRng = Range("D:D") '特定列を検索する場合コメントアウト
　　'検索基点を格納
　　Set myRng = tarRng.Cells(tarRng.Rows.Count, tarRng.Columns.Count)
　　'検索値,A1セル,値,部分一致,行方向,順方向,大/小文字区別無し,半/全角区別無しで検索
　　Set hit = tarRng.Find( _
　　　　What:=key, _
　　　　After:=myRng, _
　　　　LookIn:=xlValues, _
　　　　LookAt:=xlPart, _
　　　　SearchOrder:=xlByRows, _
　　　　SearchDirection:=xlNext, _
　　　　MatchCase:=False, _
　　　　MatchByte:=False)
　　'検索が見つからなかった時の処理
　　If hit Is Nothing Then
　　　　MsgBox """" & key & """が見つかりません"
　　　　Exit Sub
　　End If
　　bk_hit = hit.Address
　　ReDim data(Colcnt, 1)

'繰り返し検索処理
　　Do
　　　　'データ格納
　　　　If flag Then
　　　　　　flag = False
　　　　Else
　　　　　　data(0, cnt) = hit.Row
　　　　　　For i = 0 To UBound(myCol)
　　　　　　　　data(i + 1, cnt) = Cells(hit.Row, myCol(i)).Value
　　　　　　Next i
　　　　End If
　　　　'次検索
　　　　Set hit = tarRng.FindNext(hit)
　　　　'既一致チェック
　　　　If Application.Intersect(hit, myRng) Is Nothing Then
　　　　　　If myRng Is Nothing Then
　　　　　　　　Set myRng = Rows(hit.Row)
　　　　　　Else
　　　　　　　　Set myRng = Union(myRng, Rows(hit.Row))
　　　　　　End If
　　　　Else
　　　　　　flag = True
　　　　End If
　　　　'判定処理
　　　　If flag = False Then
　　　　　　cnt = cnt + 1
　　　　　　ReDim Preserve data(Colcnt, cnt + 1)
　　　　End If
　　Loop Until hit.Address = bk_hit

'リストビュー表示
　　With Me.ListView1
　　　　.ListItems.Clear
　　　　.ColumnHeaders.Clear
　　　　'初期化
　　　　.View = lvwReport　　　　 '外観表示指定
　　　　.LabelEdit = lvwManual　　 '左端項目の編集設定
　　　　.HideSelection = False　　 'フォーカス移動時の選択解除設定
　　　　.AllowColumnReorder = True '列幅の変更有無
　　　　.FullRowSelect = True　　 '行全体を選択有無
　　　　.Gridlines = True　　　　 'グリッド線表示有無
　　　　'列見出し作成
　　　　If UBound(myLabel) = -1 Then
　　　　　　.ColumnHeaders.Add , , "列番号", 0 '最後の引数(数値)が列幅
　　　　Else
　　　　　　.ColumnHeaders.Add , , myLabel(0), 0 '最後の引数(数値)が列幅
　　　　End If
　　　　If UBound(myCol) = UBound(myLabel) - 1 Then
　　　　　　For i = 0 To UBound(myLabel) - 1
　　　　　　　　.ColumnHeaders.Add , , myLabel(i + 1)
　　　　　　Next
　　　　Else
　　　　　　For i = 0 To UBound(myCol)
　　　　　　　　.ColumnHeaders.Add , , myCol(i) & "列"
　　　　　　Next
　　　　End If
　　　　'行番号の桁表示様式作成
　　　　frm = WorksheetFunction.Rept("0", Len(CStr(data(0, cnt - 1))))
　　　　'データ登録
　　　　For cnt = 0 To UBound(data, 2) - 2
　　　　　　With .ListItems.Add
　　　　　　　　'行番号登録
　　　　　　　　.Text = Format(data(0, cnt), frm)
　　　　　　　　'4番目の要素が空白以外なら着色
　　　　　　　　If Len(data(4, cnt)) > 0 Then
　　　　　　　　　　.ForeColor = RGB(255, 0, 0)
　　　　　　　　End If
　　　　　　　　'指定列項目登録
　　　　　　　　For i = 1 To UBound(myCol) + 1
　　　　　　　　　　.SubItems(i) = data(i, cnt)
　　　　　　　　　　'4番目の要素が空白以外なら着色
　　　　　　　　　　If Len(data(4, cnt)) > 0 Then
　　　　　　　　　　　　.ListSubItems(i).ForeColor = RGB(255, 0, 0)
　　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　End With
　　　　Next cnt
　　End With
End Sub

'▼リストビュー選択時
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
　　Cells(CLng(Item), "D").Select
End Sub

'▼リストビュー列見出しクリックソート(不要であれば削除)
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
　　With ListView1
　　　　.SortKey = ColumnHeader.Index - 1
　　　　.SortOrder = .SortOrder Xor lvwDescending
　　　　.Sorted = True
　　End With
End Sub

回答No.3

eden3616

No.2の補足です。

ListView1コントロールは標準で利用できません。
VBEのフォーム作成画面より、「ツールボックス」の空欄を右クリック
　　　　　　　　　　　↓
「その他のコントロール」より「Microsoft ListView Control 6.0」を追加してください

ツールボックス内に「ListView」コントロールが追加されます

参考URL：

http://officetanaka.net/excel/vba/listview/01.htm

お礼

eden3616さん、ありがとうございます。

このコントロールを試させていただきました。
ListView、この度はじめて知りました。
すごく便利ですね！

リストボックスと違い、マウスのホイールでスクロールできるところが凄いです。
感激いたしました！！
ありがとうございます。

回答No.2

eden3616

最下のVBAコードを標準モジュール及びフォームモジュールに転記してください。
また、以下の箇所を変更しております。
テストデータ及びUserForm1の様式については添付画像を参照ください。
（見にくい場合：
　　https://www.dropbox.com/s/im2hlv1yvy56zvj/form.jpg?dl=0）
標準モジュールの「検索」プロシージャよりフォームを表示してください。

>●設置するもの
>ユーザーフォーム(UserForm1)
>テキストボックス(TextBox1)
>コマンドボタン(CommandButton1)
>リストボックス(ListBox1)
　VBでは可能ですがVBAではListBoxの文字色着色はテクニックがいるためListView1で代用

>●リストボックスに(1行ごとに)表示するもの●
>(左から)I列の値、D列の値、O列の値、Q列の値(→4列の値になります)
　リストビュー選択時におけるセル選択での利便性より、１項目目に行番号を追加

///////////////// VBAコード（標準モジュール） /////////////////

'■標準モジュールに記述

'▼検索フォームの表示
Sub 検索()
　　UserForm1.Show 'vbModeless '必要に応じてコメントアウト
End Sub

///////////////// VBAコード（フォームモジュール） /////////////////

'■フォームモジュール(UserForm1)に記述

'▼検索ボタンクリック時
Private Sub CommandButton1_Click()
'宣言
　　Dim key As String, myCol As Variant
　　Dim hit As Range, bk_hit As String
　　Dim data() As String, flag As Boolean
　　Dim cnt As Long, i As Long, frm As String

'準備
　　'リストビューに表示する列を設定
　　myCol = Split("I,D,O,Q", ",")
　　'検索値を格納
　　key = Me.TextBox1.Value
　　'検索値,A1セル,値,部分一致,行方向,順方向,大/小文字区別無し,半/全角区別無しで検索
　　Set hit = Cells.Find( _
　　　　What:=key, _
　　　　After:=Cells(Rows.Count, Columns.Count), _
　　　　LookIn:=xlValues, _
　　　　LookAt:=xlPart, _
　　　　SearchOrder:=xlByRows, _
　　　　SearchDirection:=xlNext, _
　　　　MatchCase:=False, _
　　　　MatchByte:=False)
　　'検索が見つからなかった時の処理
　　If hit Is Nothing Then
　　　　MsgBox "値が見つかりません"
　　　　Exit Sub
　　End If
　　bk_hit = hit.Address
　　ReDim data(4, 1)

'繰り返し検索処理
　　Do
　　　　'データ格納
　　　　If flag Then
　　　　　　flag = False
　　　　Else
　　　　　　data(0, cnt) = hit.Row
　　　　　　For i = 0 To UBound(myCol)
　　　　　　　　data(i + 1, cnt) = Cells(hit.Row, myCol(i)).Value
　　　　　　Next i
　　　　End If
　　　　'次検索
　　　　Set hit = Cells.FindNext(hit)
　　　　'既一致チェック
　　　　For i = 0 To UBound(data, 2) - 1
　　　　　　If CInt(data(0, i)) = hit.Row Then
　　　　　　　　flag = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next i
　　　　'判定処理
　　　　If flag = False Then
　　　　　　cnt = cnt + 1
　　　　　　ReDim Preserve data(4, cnt + 1)
　　　　End If
　　Loop Until hit.Address = bk_hit

'リストビュー表示
　　With Me.ListView1
　　　　.ListItems.Clear
　　　　.ColumnHeaders.Clear
　　　　'初期化
　　　　.View = lvwReport　　　　 '外観表示指定
　　　　.LabelEdit = lvwManual　　 '左端項目の編集設定
　　　　.HideSelection = False　　 'フォーカス移動時の選択解除設定
　　　　.AllowColumnReorder = True '列幅の変更有無
　　　　.FullRowSelect = True　　 '行全体を選択有無
　　　　.Gridlines = True　　　　 'グリッド線表示有無
　　　　'列見出し作成
　　　　.ColumnHeaders.Add , , "行番号", 40
　　　　For i = 0 To UBound(myCol)
　　　　　　.ColumnHeaders.Add , , myCol(i) & "列"
　　　　Next
　　　　'行番号の桁表示様式作成
　　　　frm = WorksheetFunction.Rept("0", Len(CStr(data(0, cnt))))
　　　　'データ登録
　　　　For cnt = 0 To UBound(data, 2) - 1
　　　　　　With .ListItems.Add
　　　　　　　　'行番号登録
　　　　　　　　.Text = Format(data(0, cnt), frm)
　　　　　　　　'4番目の要素が空白以外なら着色
　　　　　　　　If Len(data(4, cnt)) > 0 Then
　　　　　　　　　　.ForeColor = RGB(255, 0, 0)
　　　　　　　　End If
　　　　　　　　'指定列項目登録
　　　　　　　　For i = 1 To UBound(myCol) + 1
　　　　　　　　　　.SubItems(i) = data(i, cnt)
　　　　　　　　　　'4番目の要素が空白以外なら着色
　　　　　　　　　　If Len(data(4, cnt)) > 0 Then
　　　　　　　　　　　　.ListSubItems(i).ForeColor = RGB(255, 0, 0)
　　　　　　　　　　End If
　　　　　　　　Next i
　　　　　　End With
　　　　Next cnt
　　End With
End Sub

'▼リストビュー選択時
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
　　Cells(CInt(Item), "D").Select
End Sub

'▼リストビュー列見出しクリックソート(不要であれば削除)
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
　　With ListView1
　　　　.SortKey = ColumnHeader.Index - 1
　　　　.SortOrder = .SortOrder Xor lvwDescending
　　　　.Sorted = True
　　End With
End Sub

補足

eden3616さん、ありがとうございます。
お返事遅くなりまして、申し訳ございません。

こんなに素晴らしいコードを教えていただきまして、とても嬉しいかぎりです！
自分が考えていたより遥かに高度で便利なアプリケーションにしていただきまして、感謝いたします。

コードを貼り付けるそれぞれのモジュールまで導いていただいた上に、
非常に分かりやすい画像・コードごとにコメントまでつけていただきまして、その配慮に頭が下がります。

実際に試させていただきまして、
自分のパソコン環境(スペック)などから、どうしても動作が少々遅くなってしまうことがわかりました。
(エクセル自体、数千行という膨大なデータがあるため、遅くなってしまうのは致し方ないのですが。)

そこで大変お手数おかけしますが、もっとも頻繁に検索するD列のみを検索するようにしたら動作が速くなるのでは?と考えまして、
以下の条件に変更したコードを教えていただけないでしょうか。

●検索するときの条件
(4)今、開いているワークシート上の「全てのセルが検索対象(列や行を指定しない)」

↓↓↓【変更】↓↓↓

(4)今、開いているワークシート上の「すべてのD列セルのみを検索対象にする」

また、仕様上、B列にExcelの行番号とは別の番号を表示しているため、見間違いをなくすため、行番号・列番号の見出しを非表示にしていることもありまして、
リストビュー上の【１項目目の行番号】を非表示にしていただく(無くす)ことは可能でしょうか。
(利便性を視野に入れた配慮に反する注文になってしまい、本当に申し訳ございません。)

もし、可能でしたら上記の2つを変更したコードを考えていただけましたら幸いです。
長文失礼いたしました。

回答No.1

Nouble

検索の本体の関数だけ
マシン破損につき
今エクセルが手元に無いもので
申し訳ない

http://sp.okwave.jp/qa/q8935313/a24828401.html
此処にファンクション形式で
書いてありますので
ご閲覧頂きたい

申し付けて頂ければ
使用変更もします

まぁ、
ファンクションコールの際の引数に
入力ダイアログボタンを埋め込めば
行けるかと思いますよ

解説はこちら
http://excelvba.pc-users.net/fol7/7_1.html

http://officetanaka.net/excel/vba/tips/tips137.htm

http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_080.html

お礼

Noubleさん、ありがとうございます。

解説先のリンクもとても参考になりそうですね。
さっそくブックマークさせていただきました。

また気になることがありましたら、ご連絡させていただくかもしれません。
感謝いたします。