マクロでキーワードを抽出して別のシートに貼り付けする

質問

セルA列にキーワードCCCが含まれていた場合に
その行を削除してSheet2に貼り付けをしたく、下記のソースを
書いてみましたがエラーがでてしまいます。
どこが間違っているか添削していただけないでしょうか？

Sub キーワード切取貼付()
Dim r As Range
For Each r In Range("A1", Range("A65536").End(xlUp))

Do
Set r = Range("A:A").Find(What:=CCC, LookAt:=xlPart)
If r Is Nothing Then Exit Do
r.Worksheets("Sheet1").Range("A:A").Cut
r.Worksheets("Sheet2").Range("A1").PasteSpecial
Loop

Next

End Sub

回答No.3

merlionXX · ベストアンサー

merlionXXです。

> After:=Range("A65536").End(xlUp))
> の意味は次のシートも続けて検索しますよ、ということですよね？

(´^∇^)σ　ち、違いますよ～
最終行を指定しておいて変だと思われるでしょうが一番先頭のA1セルから順に検索しなさいということです。
Findは、After:=で指定した基準セル（何も指定しない場合はA1）の次のセルから検索を始めます。もしA1にヒットする対象（*CCC*）があると、これが一番最後に検索され、移動先のSheet2では最下行になってしまいます。
それじゃgoo0607さんが困るかなあと思って最終セルを基準セルに指定してみました。これで先頭のA1から順に検索されるはずです。

あと、やってみればわかると思いますが、現在のコードでは切り取られた行が空白のまま残ってしまいますが、このままでいいんですか？
もし空白行を上に詰めたいのであれば以下のようにしてみてください。
ちょいとサービスし過ぎかなあ　(*´О｀*)?

Sub キーワード切取貼付02()
Dim r As Range, ur As Range, rr As Long
Dim rd(), v
Set r = Range("A1", Range("A65536").End(xlUp)).Find(What:="CCC", LookAt:=xlPart, After:=Range("A65536").End(xlUp))
If r Is Nothing Then 'なかったら
MsgBox "ありません", vbCritical, "？　(￣～￣;)う～ん　　"
Exit Sub '終了
Else 'あったら
Do Until r Is Nothing '対象がなくなるまで
ReDim Preserve rd(rr) '動的配列を用意
rd(rr) = r.Address(0, 0) '対象セルアドレスを配列に格納
rr = rr + 1 'カウント
r.EntireRow.Cut Destination:=Sheets("Sheet2").Cells(rr, 1) '行の切り取り貼り付け
Set r = Range("A1", Range("A65536").End(xlUp)).FindNext(r) '連続検索
Loop '繰り返し
For Each v In rd() '各配列要素を
If ur Is Nothing Then
Set ur = Range(v)
Else
Set ur = Union(Range(v), ur) 'ユニオンに
End If
Next v
ur.EntireRow.Delete 'ユニオンセルの属す行を一括削除
Set ur = Nothing
Set r = Nothing
End If
MsgBox rr & "件をSheet2に移動しました。", vbInformation, " （￣ー￣）v"
End Sub

お礼

先生すごいです。できそこないの生徒ですいません。
ちょっと後半ついていけてないですが、本買いましたので調べてがんばります。
先生！次回はふりがなをマクロでつけることに挑戦したいと思います。

回答No.2

merlionXX

て、添削のしようが・・・・φ(￣_￣；)　

Sub キーワード切取貼付()
Dim r As Range, rr As Long
Set r = Range("A1", Range("A65536").End(xlUp)).Find(What:="CCC", LookAt:=xlPart, After:=Range("A65536").End(xlUp))
If r Is Nothing Then 'なかったら
MsgBox "ありません", vbCritical, "？　(￣～￣;)う～ん　　"
Else 'あったら
Do Until r Is Nothing
rr = rr + 1 'カウント
r.EntireRow.Cut Destination:=Sheets("Sheet2").Cells(rr, 1) '行の切り取り貼り付け
Set r = Range("A1", Range("A65536").End(xlUp)).FindNext(r) '連続検索
Loop '繰り返し
Set r = Nothing
End If
MsgBox rr & "件をSheet2に移動しました。", vbInformation, " （￣ー￣）v"
End Sub

お礼

私のは全くだめなソースでした。
非常にわかりやすく、素晴らしい添削先生でした。ありがとうございました。
After:=Range("A65536").End(xlUp))
の意味は次のシートも続けて検索しますよ、ということですよね？

回答No.1

nattocurry

マクロのどの行で、どんなエラーが出るのかを書きましょう。

とりあえず、Range("A1", Range("A65536") が文法的に間違っているのは確かですけど。