'各行に行挿入するマクロ

'セル範囲を選択してMyInsertRowマクロを実行してください。

Option Explicit

Sub MyInsertRow()
    Const myTitle = "各行に行挿入"
    Dim r As Range, r2 As Range
    Dim v As Variant
    Dim rowCount As Long

    On Error GoTo err_1

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択して実行してください。", _
            vbExclamation, myTitle
        Exit Sub
    End If

    Do While True
        v = Application.InputBox( _
            prompt:="選択範囲の各行の下に行を挿入します。" & Chr$(10) _
                & "挿入行数を入力して下さい。", title:=myTitle, Type:=1)
        If VarType(v) = vbBoolean Then Exit Sub
        If v > 0 Then
            rowCount = v
            Exit Do
        End If
    Loop

    For Each r In Selection.Areas
        For Each r2 In r.Offset(1).EntireRow.Rows
            r2.Resize(rowCount).Insert
        Next
    Next
    Exit Sub
err_1:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, myTitle
End Sub