VBAで条件が一致する行をコピーしその1つ下へ挿入

A3からデータが入っています。
データは3行目～100行程度

そのデータ中でAH列の値が空白ではない場合
①対象行をコピーしその1つ下に挿入。
②挿入した行において　AH列の値⇒AE列、AI列の値⇒AF列へ　値貼り付け

もしAH列が空白の場合、何もせず次の行を見に行く・・・。

といった処理をマクロでしたいのですが、難しすぎて全く分からず困っています。
ご教授お願いできないでしょうか？

No.1 ベストアンサー 回答者： tom04 回答日時： 2019/12/06 18:36

こんばんは！

行挿入後、行ごとコピー＆ペーストしてもよいのですが、
少しでも時間短縮ができるかな？と思い、最終列までのコピー＆ペーストにしてみました。

尚、2行目は項目行になっていて、最終行まで項目名が入っているという前提です。

100行程度であれば単純にループさせるのが簡単だと思います。
一例です。

Sub Sample1()
　Dim i As Long, lastCol As Long
　　lastCol = Cells(2, Columns.Count).End(xlToLeft).Column
　　　Application.ScreenUpdating = False
　　　　For i = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
　　　　　If Cells(i, "AH") <> "" Then
　　　　　　Rows(i + 1).Insert
　　　　　　Range(Cells(i, "A"), Cells(i, lastCol)).Copy Cells(i + 1, "A")
　　　　　　Cells(i + 1, "AE") = Cells(i, "AH")
　　　　　　Cells(i + 1, "AF") = Cells(i, "AI")
　　　　　End If
　　　　Next i
　　　Application.ScreenUpdating = True
　　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？

※　②に関して当方の勘違いかもしれませんが、
挿入前のAH列の値を挿入後のAE列へ
挿入前のAI列の値を挿入後のAF列へ
としています。

挿入後の行内での操作にしたい場合は
＞Cells(i + 1, "AE") = Cells(i, "AH")
を
＞Cells(i + 1, "AE") = Cells(i+1, "AH")
に変更してください。
（次の行も同じように変更）

※　一旦マクロを実行すると元に戻せません。
元データに手を加えるコードなので
別シートにコピー＆ペーストしてマクロを試してください。m(_ _)m

この回答へのお礼

こんばんは
本当に丁寧に教えていただきありがとうございました。
無事テスト環境で試すと正常に動きました。
大変感謝致します、ありがとうございました。

お礼日時：2019/12/06 19:35