いつも、参考にさせて頂いております。本当に有難く思っております。
下記の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
お礼
二日も前にご回答頂いていたのに、お礼が遅れて本当にすみません。 数日間、回答が無かったものですから、半ば諦めておりました。 rr = 1 これで、解決いたしました。本当に有難うございます。これで、枕を高くして眠れます。 それにしましても、自宅のPCにExcelがないのに、即座に、初期値の設定だと見抜く実力には、敬服いたします。もっと、勉強して toras9000様のようになりたいと思います。 本当に有難うございました。