Trying to make this Macro Apply to Every Populated Row??

Currently this macro will insert a row above the highlighted row and copy and past data from the above row into the new row and populate the last cell in the second row with "Shipping". Is there any way to make this apply to all populated rows in an excel sheet? or even apply it to 20 or 30 at a time?

Thank you in advance for any help!

Moderator's note: Please take the time to review our rules. There aren't many, and they are all important. Rule #3 requires code tags. I have added them for you this time because you are a new member. --6StringJazzer

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q

    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 1).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 1).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 1).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(-1, 1).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveCell.Offset(1, -1).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(0, 3).Range("A1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Shipping"
    ActiveCell.Offset(10, -1).Range("A1").Select
End Sub

Assuming your headers are in row 1, try this:

Sub copy_row()
Dim x&, y&, i&, c As Long
Dim arr As Variant
Dim dat() As String
With ActiveSheet.UsedRange
    arr = .Value
    c = UBound(arr, 2)
    ReDim dat(1 To 2 * UBound(arr, 1), 1 To c)
    For y = 1 To c
        dat(1, y) = arr(1, y)
    Next y
    For x = 2 To UBound(arr, 1)
        For i = 1 To 2
            For y = 1 To c
                dat(x * 2 + i - 3, y) = arr(x, y)
            Next y
            If i = 2 Then dat(x * 2 + i - 3, c) = "Shipping"
        Next i
    Next x
End With
With Sheets.Add
    .Range("A1").Resize(UBound(dat, 1), c).Value = dat
    .Columns.AutoFit
End With
End Sub