I worked on creating the macro below about a year ago, and am now having to revisit it. The goal is to insert a number of blank rows between the existing filled rows in your selection. It works beautifully, EXCEPT that it operates on the whole sheet, not just the selection, and I'm stymied on how to fix it. Any help is appreciated. 
Sub Rows_InsertRowsBetweenExistingRows()
    If Selection.Rows.Count < 2 Then
        MsgBox "You first need to select the range in which to add the extra lines", vbOKOnly, "Insert Rows"
        Exit Sub
    End If

    Dim Num As String

    Num = InputBox("Type in the number of lines you want between each line in your selection", "Insert Rows")

    
        If Num = vbNullString Then
            Exit Sub
        End If
        If Num < 1 Then
            Exit Sub
        End If
        Application.ScreenUpdating = False
        Dim numRows As Integer
        Dim r As Long
        r = Selection.Row + Selection.Rows.Count - 1

        numRows = Num
        For r = r To 1 Step -1
            ActiveSheet.Rows(r + 1).Resize(numRows).Insert
        Next r
   
    Application.ScreenUpdating = True

End Sub