gooドクター有料プランが1ヶ月間無料!

Sheet1に1行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
gooドクター

A 回答 (2件)

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

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

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

の3行を

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

に差し替えてお試しください。
    • good
    • 0
この回答へのお礼

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

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

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


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

の3行を

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

に修正してみてはいかがでしょうか。
この回答への補足あり
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

このカテゴリの人気Q&Aランキング