Macro runs Slowly

Hi Guys,



The macro below works perfectly fine. It creates 250 rows in Sheet 1 and copies formula . Then it does the similar

thing in Sheet 2. However this macro runs slowly. Can any one speed it up?

Thanks

Sub InsertRowS1()
'
    ActiveSheet.Unprotect Password:="team"

  '   Stop screen refresh
'    Application.ScreenUpdating = False

'   Insert Blank Row
    Worksheets("Data Input -Unit Leaders").Activate
    Application.Goto Reference:="R1000000C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(-1, 0).Select
    Rows(ActiveCell.Row).Select
    
'   Loop 100 times
    i = 1
    Do
    Rows(ActiveCell.Row).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'   Copy Formulas, & paste in blank row
    ActiveCell.Offset(3, 0).Select
    Rows(ActiveCell.Row).Select
    Selection.Copy
    ActiveCell.Offset(-3, 0).Select
    Rows(ActiveCell.Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveCell.Offset(1, 0).Select
    i = i + 1
    Loop Until i = 250
    ActiveSheet.Protect Password:="team"
    
'   Insert Blank Row
    Worksheets("Ranking  - Unit Leaders").Activate
    ActiveSheet.Unprotect Password:="team"
    Application.Goto Reference:="R1000000C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(-1, 0).Select

'   Loop 100 times
    i = 1
    Do
    Rows(ActiveCell.Row).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'   Copy Formulas, & paste in blank row
    ActiveCell.Offset(-1, 0).Select
    Rows(ActiveCell.Row).Select
    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    Rows(ActiveCell.Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveCell.Offset(1, 0).Select
    i = i + 1
    Loop Until i = 250
    ActiveSheet.Protect Password:="team"

'   Start Screen refresh
    Application.ScreenUpdating = True
  
   

End Sub