Sub 空白行を1行おきに挿入して項目コピー()
    Dim i As Integer, 最終行 As Integer
    最終行 = Range("A1").End(xlDown).Row
   
    貼り付け行 = 最終行 * 2 - 2   '------------挿入した後の最終行は2倍、最後は項目不要のため
    'MsgBox i
   ' MsgBox 最終行
   ' MsgBox 貼り付け行
    For i = 最終行 To 3 Step -1               '------3行目から1行づつ挿入
            Cells(i, "A").EntireRow.Insert
            Cells(i, "A").EntireRow.ClearFormats
    Next
    For i = 3 To 貼り付け行 Step 2  '----3列目から
 'For j = 3 To 6
 For j = 1 To 貼り付け行 '-----1列目
 Cells(1, j).Copy Cells(i, j)
 Next j
 Next i
End Sub