excel マクロで複数シート検索し行をコピー

質問

excel2010 マクロで下記のようなことをしたいのですが
どのようにしたら良いか教えていただけないでしょうか？

(1)sheet1のA1を検索用の欄とする
(2)sheet2・sheet3・sheet4にはそれぞれデータを入力しておく
（A列～H列
まで使用し、行数は多くても500程度）
(3)sheet1のA1に検索したい単語を入力することで、sheet2・sheet3・sheet4全てのA列を検索する
(4)一致（部分一致）したら、その行をsheet1の10行目以降にコピーする
なお複数ヒットすると思われるため、複数ヒットした場合には行を追加しながらコピーしたいです。

マクロでは無理なのでしょうか？
どのように書いたらよいか、参考になるHPでも助かりますので、教えていただきたく
よろしくお願いします。

回答No.1

keithin · ベストアンサー

各シートごとに標準的な検索のDo Loopを回すだけです。

手順：
シート１のシート名タブを右クリック、コードの表示を開始する
現れたシートに下記をコピー貼り付ける

private sub Worksheet_Change(byval Target as excel.range)
　dim w as worksheet
　dim c as range
　dim c0 as string
　if target.address <> "$A$1" then exit sub
　if target = "" then exit sub

’準備　実際に応じて工夫する
　worksheets("Sheet1").range("A9").value = "res"
　worksheets("Sheet1").range("A10:H65536").clearcontents
　application.enableevents = false

’「実際に」検索したいシートの構成に応じて工夫する
　for each w in worksheets(array("Sheet2", "Sheet3", "Sheet4"))
　　set c = w.range("A:A").find(What:=worksheets("Sheet1").range("A1").value, lookin:=xlvalues, lookat:=xlwhole)
　　if not c is nothing then
　　　c0 = c.address
　　　do
　　　　c.entirerow.copy destination:=worksheets("Sheet1").range("A65536").end(xlup).offset(1)
　　　　set c = w.range("A:A").findnext(c)
　　　loop until c.address = c0
　　end if
　next

　application.enableevents = true
end sub

ファイルメニューから終了してエクセルに戻る
シート１のＡ１セルに記入すると自動でコピーしてくる。

お礼

ありがとうございます！
無事にできました！
初心者なのですが、シート名など調整しやすい形で大変助かりました。

回答No.2

keithin

ん？　どっちなんでしょうか。

＞一致（部分一致）したら

一致したら：
lookat:=xlwhole

部分一致なら：
lookat:=xlpart

お礼

すみません紛らわしくて。
部分一致でした。