Adding New Rows

'Add a new row every other row
Private Sub AddNewRows()
    Application.ScreenUpdating = False
    Range("A1").Select
    ActiveSheet.UsedRange.Select
    r = Selection.Rows.Count
    For i = 1 To r
        Rows(i * 2).Insert Shift:=xlDown
    Next i
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub



'Add a new row after a specific word in Column A and repeat on that word.
Sub AddRowForm()
    Dim iLoop As Integer
    Dim rNa As Range
    Dim i As Integer
    Dim FindIt As String
    Dim Prompt As String
    Dim Title As String

    Prompt = "What is the original value you want to replace? (Note this only works on Column A)"
    Title = "Search Value Input"
    FindIt = InputBox(Prompt, Title)
    On Error Resume Next
    iLoop = WorksheetFunction.CountIf(Columns(1), FindIt)
    Set rNa = Range("A1")
    For i = 1 To iLoop
        Set rNa = Columns(1).Find(What:=FindIt, After:=rNa, LookIn:=xlValues, LookAt:=xlWhole, _
                                  SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
        rNa.EntireRow.Offset(1, 0).Insert
    Next i
End Sub