エクセルのＶＢＡマクロで検索と結果表示（抽出）

質問

エクセルのＶＢＡマクロで検索と結果表示（抽出）を行いたいです。
業務で使用している膨大なリストデータから、特定のキーワードで情報の絞り込みを行いたいのですが、上手くマクロが組めません。

機能としては、シート１で特定のキーワード（テキストボックスに）を入力し検索ボタンを押下すると、
シート２のリストデータから検索に引っかかったセルの"行"を、シート１にリストアップ（貼り付け）していくようなマクロを作りたいのです。
シート２にはB列～AH列ｘｎ行のリストデータがあり、シート２のＫ列のセル内から「シート１のテキストボックスで入力したキーワードを含む」検索を行い、
HITした行をシート１のA9の行から結果として表示を行いたいんです。

簡単に言えばオートフィルタ機能の部分一致版を作りたいのですが・・・。
（オートフィルタでは完全一致でしか抽出が出来ないので）
そして、検索ボタンを押下すると前回結果はクリアしたいです。

ネット上のサンプル等も参考にしながらやってみたのですが上手く行きません。。。
どなたか上記のマクロ文をご教授願えないでしょうか。

必要な情報（シート２の特定の列）のみ表示させたいとも思いましたが、むずかしくて断念・・・。
もし可能でしたらこちらもお願い致します。

よろしくお願いいたします。

回答No.4

mitarashi · ベストアンサー

A No.1です。手抜きが露呈してしまいました。
下記の様に検索して、hitした範囲を一旦Range型の変数に受けて、それがNothing(hitしない）かどうかで分岐してはいかがでしょうか。
errorHandle:のところは、開発中のエラー処理にとどまっていて、現在のコードではhitしない場合は対象にはなっていませんね。失礼いたしました。
Sub test()
Dim targetRange As Range
Dim matchRange As Range

With ThisWorkbook
Set targetRange = Intersect(.Sheets("Sheet2").Columns("K"), .Sheets("Sheet2").UsedRange)
Set matchRange = findRange(targetRange, "はずれ")
If matchRange Is Nothing Then
MsgBox "見つかりませんでした"
Else
Call pasteAreas(matchRange, .Sheets("Sheet1").Range("a1"))
End If
End With
End Sub

回答No.3

mitarashi

A No.1です。
過去に似たようなものを作ったのを思い出しました。少しアレンジして試したところ動く様です。（順番が変わってしまう問題はありますが）検索ワードを入力する部分は無いのでご自分で作成願います。お役に立てば幸いです。なお、検索部分はXL2000のHELPのコードをちょっといじったものです。
Sub test()
Dim targetRange As Range

With ThisWorkbook
Set targetRange = Intersect(.Sheets("Sheet2").Columns("K"), ThisWorkbook.Sheets("Sheet2").UsedRange)
Call pasteAreas(findRange(targetRange, "試験"), .Sheets("Sheet1").Range("a1"))
End With
End Sub

Function pasteAreas(target As Range, destRange As Range)
Dim myArea As Range
Dim targetRow As Range

For Each myArea In target.Areas
For Each targetRow In myArea.Rows
targetRow.EntireRow.Copy destRange
Set destRange = destRange.Offset(1, 0)
Next
Next
End Function

Private Function findRange(targetRange As Range, matchString As String) As Range
Dim c As Range
Dim firstAddress As String

On Error GoTo errorHandle
With targetRange
Set c = .Find(matchString, LookIn:=xlValues, LookAt:=xlPart)
Set findRange = c
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
If Not c Is Nothing Then Set findRange = Union(findRange, c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
errorHandle:
Select Case Err.Number
Case 0

Case 91
MsgBox "該当するデータはありません"
Case Else
MsgBox Err.Number & vbCrLf & Err.Description
End Select
End Function

補足

有難う御座います。
文法を調べながら弄らせて貰っています。

なんとか検索の機能部分と、結果表示クリアの機能部分は自力で追加できて、個人レベルで使用するのには耐えれるレベルにはなったとは思います。

しかし１つだけ問題がありまして、mitarashi様の提示して頂いたコードを使用すると、一致条件がない場合の処理が上手く動いていないようで、「オブジェクト変数または With ブロック変数が設定されていません」とエラーが出ます。
（こちらのエラーは提示して頂いた文をそのまま使用しても出ます）

いろいろと調べながら弄ってはいるのですが、何度やっても該当データがない場合の処理が上手くいきません。。。errorHandleの処理もいまいちよく理解出来ていません。（すいません）

可能でしたらこちらの対処方法もご教授下さい。

回答No.2

hana-hana3

＞オートフィルタでは完全一致でしか抽出が出来ないので

部分一致で抽出する事ができます。
（フィルタオプションでも設定できます。）

Selection.AutoFilter Field:=1, Criteria1:="=*hogehoge*"
とか
Selection.AutoFilter Field:=1, Criteria1:="=*" & Textbox1.text & "*"

お礼

そんな機能もあったのですね。
仕事の合間にちょこちょこ試行錯誤しているので、後ほど試して見ます。
有難う御座いました。

回答No.1

mitarashi

>簡単に言えばオートフィルタ機能の部分一致版を作りたいのですが・・・
フィルタオプションはいかがですか。詳細は参考URLをご覧下さい。

参考URL：

http://www11.plala.or.jp/koma_Excel/contents6/mame6043/mame604302.html

お礼

そんな機能があったとは・・・はじめて知りました。
参考URLを確認してみましたが、高度な抽出などが条件式で行えるのですね。
ありがとうございます。
ただ、やはり簡単にマクロ化したいですね。