検索後、行を抽出するVBAのProcedureで、

質問

いつも、参考にさせて頂いております。本当に有難く思っております。
下記のProcedureを使わせていただきたいのですが、検索シートのRange("A1:S1")に見出し行が、ありまして、貼り付け先シートにも見出し行をコピーして、その下の行から Do Loopでコピペしたいのですが、どうしても、記述の仕方がわかりません。MerlionXX様、及び、他にお解りになる方、どうか、お教えください。
1行目に行を挿入したり、Selection.Offset(1, 0).Select　で1行さげて、そこへ見出し行をコピペしたりしましたが、貼り付け先シートの1行目のデータが、消えてしまうのです。そのデータの上に見出し行が、貼り付けられてしまうのです。　
　　Selection.Insert Shift:=xlDown　これもダメでした。　夜も眠れません。どなたか、下記のProcedure をどのように書き換えたら、貼り付け先シートに見出し行がコピペされ、その次の行から、
検索した行が、繰り返し貼り付けられるようになるのか、お教えください。

Sub test01()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range
Dim myStr, ra, rr
myStr = InputBox("検索する文字", "　(´^∇^)σ　入力してください", "")
If myStr = "" Then
MsgBox "検索文字未指定", vbCritical, "　Σ（￣ロ￣lll)"
Exit Sub
End If

Set ws1 = Sheets("Sheet1") '検索　シート
Set ws2 = Sheets("Sheet2") '貼付先シート
With ws1.Columns("A") '部分一致で検索（A列）

Set rng = .Find(What:=myStr, LookAt:=xlPart, After:=.Cells(.Cells.Count))
If rng Is Nothing Then 'なかったら
MsgBox "ありません", vbCritical, myStr & "？　(￣～￣;)う～ん　　"
Else 'あったら
ra = rng.Address '最初に見つかったセルアドレス

Do
rr = rr + 1 'カウント
rng.EntireRow.Copy Destination:=ws2.Cells(rr, 1) '行のコピペ
Set rng = .FindNext(rng) '連続検索
Loop While rng.Address <> ra '繰り返し
Set rng = Nothing
End If
End With

MsgBox rr & "件をSheet2に抽出しました。", vbInformation, " （￣ー￣）v"
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

宜しくお願い申し上げます。m(-_-)m

回答No.1

noname#251971 · ベストアンサー

当方、自宅のPCにExcelがありませんので、
質問内容とコードをみただけでの回答となります。
もし見当はずれでしたらスルーしていただければと思います。

質問内容は、コピー先にて、常にシートの1行目から貼り付けが行われてしまうのを、
2行目から貼り付けられるようにしたい、という趣旨かと認識いたしました。

記載いただいたコードですと、変数「rr」の値に初期値がありませんので、
常に先頭から貼り付けが行われる動作になるのかと思われました。

Do の行の前で、

rr = 1

の1行を加えることで、目的の動作になるのではないかとおもわれます。

お礼

二日も前にご回答頂いていたのに、お礼が遅れて本当にすみません。
数日間、回答が無かったものですから、半ば諦めておりました。

rr = 1 これで、解決いたしました。本当に有難うございます。これで、枕を高くして眠れます。

それにしましても、自宅のPCにExcelがないのに、即座に、初期値の設定だと見抜く実力には、敬服いたします。もっと、勉強して　toras9000様のようになりたいと思います。

本当に有難うございました。