excel2010 マクロで複数シート検索し、一致した行をコピーしたい

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

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

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

No.1 ベストアンサー 回答者： soixante 回答日時： 2015/08/23 19:19

こんなのどうでしょうか。

実行後は戻せませんので、元データはバックアップのうえ、お試しください。

検索ワードは、Sheet1のA1セルとしています。

-------------------------------------------------------------------------
Sub AAA()
Dim r As Long, k As Integer
Dim Ws1 As Worksheet
Dim Moji As String, Rng As Range, Lstrow As Long

Set Ws1 = Worksheets(1)
With Ws1
.Range(.Rows(10), .Rows(Rows.Count)).ClearContents
End With

Moji = Ws1.Cells(1, 1).Value

For k = 2 To 4
r = 2
With Worksheets(k)
Do While .Cells(r, 1).Value <> ""
If InStr(.Cells(r, 1), Moji) <> 0 Then
Set Rng = .Range(.Cells(r, 1), .Cells(r, 8))
Rng.Copy

Lstrow = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Lstrow < 10 Then Lstrow = 10
Ws1.Cells(Lstrow, 1).PasteSpecial Paste:=xlPasteAll
End If

r = r + 1
Loop
End With
Next k
Ws1.Cells(1, 1).Select
Application.CutCopyMode = False

Set Rng = Nothing
Set Ws1 = Nothing

MsgBox "End."


End Sub

----------------------------------------------------------------------

この回答へのお礼

ありがとうございます！
できました！
こちらを参考にさせて頂いて、いろいろ調整してみます！

お礼日時：2015/08/24 10:25

No.2 回答者： tom04 回答日時： 2015/08/23 21:34

こんばんは！

Sheet2～Sheet4の1行目は項目行で、データは2行目以降にあるという前提です。

まず↓のコードをSheet1のシートモジュールにしてください。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long
With Target
If .Address = "$A$1" Then
'▼9行目が項目行になっていない場合、ストッパーの役目（念のため）
If .Value <> "" Then
If Range("A9") = "" Then
Range("A9") = "ダミー"
End If
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 9 Then
Range(Cells(10, "A"), Cells(lastRow, "H")).Clear
End If
Call Sample1
End If
End If
End With
End Sub

次に↓のコードを標準モジュールにしてください。

Sub Sample1()
Dim k As Long, lastRow As Long, wS As Worksheet
With Worksheets("Sheet1")
For k = 2 To 4 '←Sheet2～Sheet4
Set wS = Worksheets(k)
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
wS.Range("A1").AutoFilter field:=1, Criteria1:="*" & .Range("A1") & "*"
If wS.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "H")).SpecialCells(xlCellTypeVisible).Copy .Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
wS.AutoFilterMode = False
Next k
If .Range("A9") = "ダミー" Then
.Range("A9").ClearContents
End If
End With
End Sub

※　Sheet1のA1セルにデータを入力してみてください。
※　A1セル変更のたびにマクロが実行されます。m(_ _)m

この回答へのお礼

ありがとうございます！
こういう設定方法もあるんですね。
勉強のみちのりはまだまだ続くなぁ。
参考にさせて頂いて、頑張ります！

お礼日時：2015/08/24 10:27