insert two empty rows below used data

Hello johncena,

I have add the macro below to the attached workbook. There is a button above "Date" in column 1 to run the macro.

Sub Add2Rows()

  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Sheet1")
    
    Set Rng = Wks.Range("A2")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    
    If RngEnd.Row < Rng.Row Then Exit Sub
    
    Set Rng = Wks.Range(Rng, RngEnd)
    
    Application.ScreenUpdating = False
    
      For R = Rng.Rows.Count To 2 Step -1
        Rng.Rows(R).Resize(RowSize:=2).EntireRow.Insert
      Next R
    
    Application.ScreenUpdating = True
    
End Sub