エクセルで検索結果を抽出し、別シートにコピーしたい。

いつも楽しく拝見しております。

すいません、ネットで頑張って調べたのですが、どうしても
ウマくいかないので、ご教授下さい。

エクセルにて、シート1にさまざまな情報が記載されています。
A1を検索ボックスとし、ここに入れた言葉を検索し、対象となった行のみをシート2にコピーしたいと考えています。
※書式もそのままコピーしたいです。

これをマクロにて作成し、使用者にはA1に検索内容を入れてもらった後、マクロが仕込んであるボタンをクリックすれば結果が出てくる・・・と言う形を作りたいです。

検索のみ、コピーのみであれば、それぞれ調べると乗っていたりするのですが、両方をしようとした時、どのような式が必要かがわかりません。

ちなみに、検索は以下のような記述を見つけました。

On Error Resume Next
a = InputBox("検索したい文字を入力してください。")
Cells.Find(what:=a, after:=ActiveCell, LookIn:=xlFormulas, lookat:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activate
End Sub

どのような記述を行えば出来るのでしょうか。
また、参考文献が掲載されているURLでも結構です。

どうかご教授下さい。

宜しくお願い致します。

No.1 ベストアンサー 回答者： n-jun 回答日時： 2009/01/29 17:27

＞A1を検索ボックスとし、ここに入れた言葉を検索し、

と
＞a = InputBox("検索したい文字を入力してください。")
がかみ合いませんが。

Findメソッドでのデータ検索　
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/v …
この事ではないかと。

データの範囲及びシート２の貼付ける位置が不明ですが。
InputBoxで値を入力し、シート１の全セルを検索範囲とし、シート２の１行目に貼付けるとするなら、

Sub try()
Dim str As Variant
Dim r As Range

str = InputBox("検索したい文字を入力してください。")

If str = "" Then Exit Sub

Set r = Worksheets("Sheet1").Cells.Find(What:=str, LookIn:=xlValues, _
LookAt:=xlWhole)

If r Is Nothing Then Exit Sub

r.EntireRow.Copy Worksheets("Sheet2").Rows(1)
Set r = Nothing
End Sub

こんなとか？

この回答へのお礼

早速のご回答ありがとうございました。

早速試してみました。

まさにこんな感じのことがしたかったです！！

一点教えて頂きたいのですが、これは検索結果が複数あった場合、
コピーが出来ないのでしょうか。

出来れば、検索した内容が含まれている行ごと、なおかつ複数ある
場合は全てを貼り付けたいのですが、可能でしょうか。

ご教授頂けますと幸いです。

ご回答ありがとうございました。

お礼日時：2009/01/30 11:06

No.2 回答者： n-jun 回答日時： 2009/01/30 13:09

＃１です。

＞一点教えて頂きたいのですが、これは検索結果が複数あった場合、
＞コピーが出来ないのでしょうか。
＞出来れば、検索した内容が含まれている行ごと、なおかつ複数ある
＞場合は全てを貼り付けたいのですが、可能でしょうか。

Sub try_next()
Dim str As Variant
Dim r As Range
Dim r1 As Range, r2 As Range

str = InputBox("検索したい文字を入力してください。")

If str = "" Then Exit Sub

Set r = Worksheets("Sheet1").Cells.Find(What:=str, LookIn:=xlValues, _
LookAt:=xlWhole)

If r Is Nothing Then Exit Sub

Set r1 = r
Set r2 = Worksheets("Sheet2").Range("A1")

Do
r.EntireRow.Copy r2.EntireRow

Set r = Worksheets("Sheet1").Cells.FindNext(r)
Set r2 = r2.Offset(1)
Loop Until r.Address = r1.Address

Set r = Nothing
Set r1 = Nothing
Set r2 = Nothing

End Sub

こんな感じの事でしょうか？