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

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

Option Explicit

Sub MyInsertRow()
    Const myTitle = "各行に行挿入"
    Dim r As Range
    Dim v As Variant
    Dim i As Long
    Dim iInsertCount As Integer

    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
            iInsertCount = CInt(v)
            Exit Do
        End If
    Loop

    Application.ScreenUpdating = False
    For Each r In Selection.Areas
        For i = r.Row + 1 To r.Row + 1 + _
                (r.Rows.Count - 1) * (iInsertCount + 1) Step iInsertCount + 1
            ActiveSheet.Rows(i).Resize(iInsertCount).Insert
        Next
    Next
    Exit Sub
err_1:
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, myTitle
End Sub