insert two empty rows below used data

Sub Insert2Rows()
Dim c As Long, lrow As Long
With ActiveSheet
lrow = .Cells(.Rows.Count, "A").End(xlUp).Row

For c = lrow - 1 To 1 Step -1
If .Cells(c, 1).Value <> "" Then
If .Cells(c, "A").Value <> .Cells(c + 1, "A").Value Then
.Cells(c + 1, "A").Resize(2).EntireRow.Insert
End If
End If

Next
End With

End Sub

dear friends i have found above macro from net & it's inserting empty rows base on column "A" data change,my data starting in column "A" row 2 to down.i want to insert column "A" data available all rows below two empty rows.pls help me to do that....

Hello johncena,

Can you give us an example of how the data should look before and then how it should look after the macro is run?

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