Insert 2 blank rows after each cell containing text in column A

[Zvoni]

That's not going to work with a For-Next-Loop, since you're changing the ListCount. It's the main reason why i always do things like that Bottom-Up

I don't think it's going to work Top-Down, since you don't know when to stop. What criteria do you want to define to let your Do-Loop know that it is at the end?

The only thing i can think of is along these lines:
Untested:

Sub AddBlankRowsnew()
'
Dim iRow As Long, iCol As Long
Dim oRng As Range
Dim LastRow As Long
Dim i As Integer
iCol=1
LastRow = Cells(Rows.Count, iCol).End(xlUp).Row
'Insert End-Marker
Cells(LastRow+1, iCol)="This is the End my Friend"
iRow=4
'For iRow = 4 To LastRow Step 1
Do
If Cells(iRow, iCol) <> Cells(iRow + 1, iCol) And Cells(iRow + 1, iCol) = "" Then
   For i = 1 To 2: Cells(iRow + 1, iCol).Insert Shift:=xlDown: Next
End If
iRow=iRow+1
Loop until Cells(iRow,iCol)="This is the End my Friend"
'Remove the End-Marker
Rows(iRow).Delete
'Next