マクロでキーワードを抽出して別のシートに挿入する

質問

質問番号：4733370の質問と回答を勝手に引用させて頂きます。

セルA列にキーワードCCCが含まれていた場合に
その行を削除してSheet2に貼り付けする・・・という下のマクロを
貼り付けの部分を挿入に変更したいのですが、なにぶんマクロ初心者
の為よくわからないので教えていただけないでしょうか・・
宜しくお願い致します。

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.3

merlionXX · ベストアンサー

No2 merlionXXです。
ではそのsheet2の表の4行目に挿入していきます。

Sub キーワード切取貼付03()
Dim r As Range, ur As Range
Dim rr As Long, x As Long
Dim rd(), v
x = Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("A1", Range("A" & x)).Find(What:="CCC", LookAt:=xlPart, After:=Range("A" & x))
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 'カウント
Sheets("Sheet2").Rows(4).Insert Shift:=xlDown
r.EntireRow.Cut Destination:=Sheets("Sheet2").Cells(4, 1) '行の貼り付け
Set r = Range("A1", Range("A" & x)).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.4

n-jun

Sheet2のA列の最終行に追加する案で。

Sub try()
Dim r As Range

With Worksheets("Sheet1")
.Range("A1").AutoFilter 1, "CCC" '抽出する値 "CCC"
Set r = .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible)

If r.Item(1).Row > 1 Then
r.EntireRow.Copy Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
r.EntireRow.Delete
End If

.AutoFilterMode = False
End With
End Sub

一例まで。

回答No.2

merlionXX

ご提示のコードを回答した者です。
「貼り付けの部分を挿入に変更したい」という意味がわからないのですが・・・。
現在はSheet2の1行目から順に貼り付けていますが、そうでなく切り取った行と同じ行番号のSheet2にもって行くということ？
それとも切り取らずに同じ行番号のSheet2にもって行くということ？
あるいは？？？？

補足

早速のお返事ありがとうございます。

sheet2にもsheet1と同じ形式の表があるので、そのsheet2の表の
4行目、もしくは表の最後に挿入したいと考えています。
貼り付けですと、元々あるデータが上書きされてしまうので・・
わかりづらい質問で申し訳ありませんが、宜しくお願いします。

回答No.1

xls88

その行を削除してSheet2に挿入する作業を「マクロの記録」すればコードが解ります。

「エクセルＶＢＡ」でマクロの作成
http://kiyopon.sakura.ne.jp/vba/index.htm

お礼

早速のお返事ありがとうございます。

自分なりに勉強しながらやってみますが、正直むずかしいです・・