特定のキーワードを含む行を別シートに貼り付け

Sheet1に１行21列の空白を含むデータが複数あります。
U列のセルに「月」があった場合、その行を空白のSheet2に貼り付ける以下のコードを使用しています。


これをSheet2にすでに別データがある状態で、セルL11にデータを貼り付けられるようにコードを手直ししたいです。
、つまりSheet2のデータの中に割り込みでSheet1のデータを入れたいです。

イメージとしては、Sheet2のL列からAF列に21個の空の列を挿入して、セルL11から以下にデータが貼り付いた形にになれば良いです。


手直しで何とかなりそうでしょうか？お詳しい方宜しくお願いいたします。



Sub 貼り付け()
Dim a As Long
Dim b As Long
Dim c As Long

リスト= "Sheet1"
貼り付け= "Sheet2"

b = Worksheets(リスト).Cells(Rows().Count, "F").End(xlUp).Row
c = Worksheets(貼り付け).Cells(Rows().Count, "F").End(xlUp).Row
If c = 1 And Worksheets(貼り付け).Cells(1, "U") = "" Then
Else
c = c + 1
End If


For a = b To 1 Step -1
If InStr(Worksheets(リスト).Cells(a, "U"), "月") > 0 Then

Worksheets(リスト).Rows(a).Cut
Worksheets(貼り付け).Rows(c).Insert Shift:=xlDown
Worksheets(リスト).Rows(a).Delete Shift:=xlUp
c = c + 1
End If
Next a

End Sub

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

• Sheet1のデータは貼り付きました！ありがとうございます。
  しかし以下の問題が出ました。
  
  L11ではなくK13に貼り付ついた。
  L列からAF列に列が挿入されず既存の元データが右側ににシフトされなかった。
  
  厚かましく恐縮ですが、もし解消できるのであればお願いいたします。

  No.1の回答に寄せられた補足コメントです。 補足日時：2021/07/25 19:56

No.2 ベストアンサー 回答者： SevenKnights 回答日時： 2021/07/25 21:18

ご質問中にある「Sheet2のL列からAF列に21個の空の列を挿入」はあらかじめ手作業でしておくと考えていましたが，ご質問者様の補足コメントに従って，L11からAF11の範囲を固定し，Sheet1のデータを代入した後，その下側と右側に同じセル範囲を挿入するように１行追加しました。

また，K列改めL列から代入するように修正しました。

No.1と同様に
Worksheets(リスト).Rows(a).Cut
Worksheets(貼り付け).Rows(c).Insert Shift:=xlDown
Worksheets(リスト).Rows(a).Delete Shift:=xlUp

の３行を

Range(Worksheets(リスト).Cells(a,1),Worksheets(リスト).Cells(a,21)).Cut
Range(Worksheets(貼り付け).Cells(11,12),Worksheets(貼り付け).Cells(11,32)).Insert Shift:=xlDown
Range(Worksheets(貼り付け).Cells(11,12),Worksheets(貼り付け).Cells(11,32)).Insert Shift:=xlToRight
Range(Worksheets(リスト).Cells(a,1),Worksheets(リスト).Cells(a,21)).Delete Shift:=xlUp

に差し替えてお試しください。

この回答へのお礼

とても参考になりました！
ありがとうございました。

お礼日時：2021/07/27 21:54

No.1 回答者： SevenKnights 回答日時： 2021/07/25 16:52

Worksheets(リスト).Rows(a).Cut

Worksheets(貼り付け).Rows(c).Insert Shift:=xlDown
Worksheets(リスト).Rows(a).Delete Shift:=xlUp

の３行を

Range(Worksheets(リスト).Cells(a,1),Worksheets(リスト).Cells(a,21)).Cut
Range(Worksheets(貼り付け).Cells(c,11),Worksheets(貼り付け).Cells(c,32)).Insert Shift:=xlDown
Range(Worksheets(リスト).Cells(a,1),Worksheets(リスト).Cells(a,21)).Delete Shift:=xlUp

に修正してみてはいかがでしょうか。