VBAマクロ 決まっていない行を選択して別シートへ貼付け

VBAマクロ超初心者です。
添付画像のように作成をしたいのです。
やりたいことは
①決まっていない複数行を自分で行選択し、別シート（Sheet2)切り取り貼付けしたい。
（固定の行数ではないという意味です）
②Sheet1の大元ファイルで切り抜かれた空白行は削除して上に詰めたい。

思考錯誤しましたが、まずSheet1の複数行を一度に選択し切り取ることはできないようですので
1行ずつ切り取りSheet2へ貼付けをする。その後、Sheet1の空白行をつめる

考えたマクロ
①
Sub GATTAI ()
Selection.Cut


Sheets.Add After:=ActiveSheet
ActiveSheet.Paste


②

Sub kuuhakusakujyo
Range("A1:A100").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

①で1個ずつマクロ作業を行うと、別シートに1個ずつデータが作られてしまう。
添付画像のSheet2のように下にコピーされるようにしたい

可能かどうかわかりませんが、①と②の操作を連続するマクロコードはどうなりますか？

どなたかよろしくお願いします。

質問者からの補足コメント

• 

  ご回答ありがとうございます。
  
  rng.Copy Worksheets("Sheet2").Range("A1")の箇所がエラーになります。
  
  同じブック内の、新しいシートのA1に貼り付けるとした場合の
  
  Worksheets.Add(After:=Worksheets　でしょうか？教えて頂けると幸いです。初心者ですみません。

  No.1の回答に寄せられた補足コメントです。 補足日時：2023/02/16 17:28

No.4 ベストアンサー 回答者： Qchan1962 回答日時： 2023/02/17 16:52

>'rng.Delete '行を削除するは稼働しなかったです。

'rng.Delete と　
rng.Delete の違い解りますか？　（このようにしないと実行されません）

No.3 回答者： Qchan1962 回答日時： 2023/02/16 18:09

>同じブック内の、新しいシートのA1に貼り付けるとした場合の

Sub Example_02()
'事前に手作業で行を選択している事
Dim rng As Range, r As Range
For Each r In Selection.Rows
If rng Is Nothing Then
Set rng = r.EntireRow
Else
Set rng = Union(rng, r.EntireRow)
End If
Next
Worksheets.Add after:=Worksheets(Worksheets.Count)
rng.Copy ActiveSheet.Range("A1")
'rng.Delete '行を削除する
End Sub

少し変更
選択しているセルの行全体をコピペ
（切り取る場合（元の行を削除）は　'rng.Deleteを使う）

＃２様も書かれていますが（事前の手作業）実行可能な条件がそろっているか等　エラー処理が必要だと思います

事前の手作業は少し面倒では？　選択に何だかの条件があるのであれば
条件に合わせた処理が可能だと思います

この回答へのお礼

書き込みありがとうございます。(*- -)(*_ _)ペコリ

事前作業としては、
①　表の項目A列の番号ををVBAで検索し、対象行に色を付ける。
　（※検索ウィンドウで「2,4,7（今回は）」と複数検索できる。）

②　①で色がついた行をCtrlキーで複数選択（ここが手作業）

本当の最終形はは①.②の作業+今回の質問の動作を一連作業にしたいのですが、とりあえず1個ずつわけて考えようとしました。
　

教えて頂いたコードを実行したところ
'rng.Delete '行を削除するは稼働しなかったです。

もう少し探ってみます。

ありがとうございます。

お礼日時：2023/02/17 14:55

No.2 回答者： fujillin 回答日時： 2023/02/16 17:38

こんにちは

＞添付画像のSheet2のように下にコピーされるようにしたい
まとめて処理することは可能ですが、不明点がいろいろあるので、勝手に以下のような想定をしました。

・対象はA:C列のみで良い（他の列にデータがあっても削除はされません）
・1行目はタイトル行で、選択されていなくても必ずコピーする
・A:C列以外で選択されているセルがあっても、そちらは無視する
・貼り付け先シートはSheet2とする（貼り付け前に一旦クリアします）

対象となるセル（1セルで良い、複数選択可）を選択した状態で以下を実行してください。

Sub Sample()
Dim rng As Range

If TypeName(Selection) <> "Range" Then
MsgBox "セルを選択してください"
Exit Sub
End If
Set rng = Intersect(Union(Range("A1"), Selection), Columns("A:C"))
Set rng = Intersect(rng.EntireRow, Columns("A:C"))
If rng.Cells.Count < 4 Then
MsgBox "タイトル以外も選択してください"
Exit Sub
End If

Worksheets("Sheet2").Cells.ClearContents
rng.Copy Worksheets("Sheet2").Range("A1")
Set rng = Intersect(rng, Rows(2).Resize(Rows.Count - 1))
rng.Delete (xlShiftUp)
End Sub

この回答へのお礼

いつも書き込みありがとうございます。(^^)/
いつも尊敬させて頂いております。
VBAを環境ができれば本格的に学校で勉強したいなという気持ちになっておりその前に少しでも情報をいれたくなっております。
書いて頂いたコードは無事に動いています。さすがです！！
もう少しお勉強したいのでひとまずお礼のメッセージをお送りさせて頂きます。

お礼日時：2023/02/17 11:59

No.1 回答者： Qchan1962 回答日時： 2023/02/16 16:39

こんにちは

選択した行を詰めて切り取り　貼り付けるコードの例です
元シートの複数行を選択してSheet2のA1（1行目から）貼り付けます
行を削除する場合は　コメントしてあるコードを使用します

Sub Example_01()
'事前に手作業で行を選択している事
Dim rng As Range, r As Range
For Each r In Selection.Rows
If rng Is Nothing Then
Set rng = r
Else
Set rng = Union(rng, r)
End If
Next
rng.Copy Worksheets("Sheet2").Range("A1")
'rng.Delete '行を削除する
End Sub