マクロをまとめたいです

以下のマクロをまとめたいです。
行いたいのは以下のやり方です。
AAA
BBB
CCC
↑上のようなデータに対して、下に空白の行を一行挿入する。

AAA

BBB

CCC

↑挿入した空白業にひとつ上のデータをコピーして張りつけ
AAA
AAA
BBB
BBB
CCC
CCC
↑D列の偶数行にD、奇数行にEというデータを入力する
AAAD
AAAE
BBBD
BBBE
CCCD
CCCE

この一連の流れをマクロ化したいです。
今使っているのは以下のマクロですが、バラバラなのと上手くいかないことがあるので一つにまとめてすっきりさせたいです。
行数は場合によって変わるので、最終行を取得する方法にしたいです。

Sub 一行飛ばす()
Dim i As Integer, 最終行 As Integer
最終行 = Range("A1").End(xlDown).Row
For i = 最終行 To 2 Step -1
Cells(i, "A").EntireRow.Insert
Cells(i, "A").EntireRow.ClearFormats
Next
End Sub
Sub 選択範囲()
Range("A1").Select
Range("A1", Range("C" & Rows.Count).End(xlUp).Offset(1, 0)).Select
End Sub
Sub コピー()
Dim blanks As Range
If Selection.Cells.Count > 1 Then
On Error Resume Next
For Each blanks In Selection.SpecialCells(xlCellTypeBlanks).Areas
If blanks.Row > 1 Then
blanks.Rows(1).Offset(-1, 0).Copy blanks
End If
Next
On Error GoTo 0
End If
End Sub

よろしくお願いします。

No.4 ベストアンサー 回答者： ママチャリ 回答日時： 2020/04/05 23:31

何がしたいのか、良く分かんないけど、これで良いかな？

Sub sample()
Dim i As Long
For i = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
Rows(i).Copy
Rows(i).Insert Shift:=xlDown
Cells(i, "D").Value = "D"
Cells(i + 1, "D").Value = "E"
Next i
End Sub

この回答へのお礼

ありがとうございます。
いちばん面倒な作業だったのでこれで楽になります。

お礼日時：2020/04/06 23:56

No.3 回答者： Qchan1962 回答日時： 2020/04/05 22:56

失礼、同じコードを投稿してしまいました。

Sub sample()は下記が無いものを投稿するつもりでしたすみません。

　　　　For i = dRow To 2 Step -1
　　　　　　.Cells(i, "A").EntireRow.Insert
　　　　　　.Cells(i, "A").EntireRow.ClearFormats
　　　　Next

No.2 回答者： Qchan1962 回答日時： 2020/04/05 22:53

ご質問の状態から、結果を出力するものです。

結果を見る限り空白行を挿入する必要はないと思いますので、プロセスは違います。
sample1は、当然、実際には挿入した行を他の列で使用するのは、想像できますので
空白行を挿入して、値を出力しています。
コードにあるA列1行目からが対象です。
Sub sample()
Dim i As Long, dRow As Long, j As Long: j = 1
Dim MyArray1 As Variant, MyArray2 As Variant
　　With ActiveSheet
　　　　dRow = .Range("A1").End(xlDown).Row
　　　　MyArray1 = .Range("A1:A" & dRow)
　　　　ReDim MyArray2(1 To dRow * 2, 1 To 1)
　　　　For i = LBound(MyArray1, 1) To UBound(MyArray1, 1)
　　　　　　MyArray2(j, 1) = MyArray1(i, 1) & "D"
　　　　　　j = j + 1
　　　　　　MyArray2(j, 1) = MyArray1(i, 1) & "E"
　　　　　　j = j + 1
　　　　Next i
　　　　For i = dRow To 2 Step -1
　　　　　　.Cells(i, "A").EntireRow.Insert
　　　　　　.Cells(i, "A").EntireRow.ClearFormats
　　　　Next
　　　　.Range("A1:A" & dRow * 2) = MyArray2
　　End With
End Sub

’空白行を挿入後出力
Sub sample1()
Dim i As Long, dRow As Long, j As Long: j = 1
Dim MyArray1 As Variant, MyArray2 As Variant
　　With ActiveSheet
　　　　dRow = .Range("A1").End(xlDown).Row
　　　　MyArray1 = .Range("A1:A" & dRow)
　　　　ReDim MyArray2(1 To dRow * 2, 1 To 1)
　　　　For i = LBound(MyArray1, 1) To UBound(MyArray1, 1)
　　　　　　MyArray2(j, 1) = MyArray1(i, 1) & "D"
　　　　　　j = j + 1
　　　　　　MyArray2(j, 1) = MyArray1(i, 1) & "E"
　　　　　　j = j + 1
　　　　Next i
　　　　For i = dRow To 2 Step -1
　　　　　　.Cells(i, "A").EntireRow.Insert
　　　　　　.Cells(i, "A").EntireRow.ClearFormats
　　　　Next
　　　　.Range("A1:A" & dRow * 2) = MyArray2
　　End With
End Sub

No.1 回答者： tom04 回答日時： 2020/04/05 22:07

こんばんは！

色々やり方はあると思いますが、一例です。
１行目は項目行でデータはA列2行目以降にあるということですね。

Sub Sample1()
　Dim i As Long, lastRow As Long
　Dim cnt As Long, myStr As String

　　Application.ScreenUpdating = False
　　　lastRow = Cells(Rows.Count, "A").End(xlUp).Row
　　　　'//▼空白行挿入//
　　　　Range("A:A").Insert
　　　　　With Range(Cells(2, "A"), Cells(lastRow, "A"))
　　　　　　.Formula = "=row()"
　　　　　　.Value = .Value
　　　　　End With
　　　　　Range(Cells(2, "A"), Cells(lastRow, "A")).Copy Cells(lastRow + 1, "A")
　　　　　Range("A1").CurrentRegion.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes
　　　　　'//▼各セルの操作
　　　　　For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　With Cells(i, "B")
　　　　　　　If .Value <> "" Then
　　　　　　　　myStr = .Value
　　　　　　　　.Value = myStr & "D"
　　　　　　　Else
　　　　　　　　.Value = myStr & "E"
　　　　　　　End If
　　　　　　End With
　　　　　Next i
　　　　　　Range("A:A").Delete
　　Application.ScreenUpdating = True
　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m