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

I have column A populated with some text in cells after regular intervals.. for e.g. it starts from row A4 where i have company name and after 16 or 17 blank rows I again have one more company name and so on the it goes for around 8000+ rows in column A, so after each company name cell I want to insert 2 blank rows but not the entire row just shift the cells down in column A. Below is what I have got...

Code:

---

Sub AddBlankRows()
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Range("a4")

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).Insert shift:=xlDown
    iRow = iRow + 2

End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

---

Quote:

---

where i have company name and after 16 or 17 blank rows I again have one more company name

---

do you want to insert blank rows even if the next rows are empty?

Ouch!
You're going Top-Down through your column.
Let's pretend it works. What happens?
Your loop finds the first Row matching your criteria.
You insert a row (better said: a cell with shift down).
Then you jump over that inserted row (iRow+2), and where do you land? on an empty cell (as you said that your cell with company name is followed by 16/17 blank rows).
Meaning: It would throw you out of your loop, because you match the condition cells(iRow,iCol)=""

Advice: Go Bottom-Up through your List.
Compare current row with row one up (iRow-1)
If current row is a company name, then the row one up should be empty (If cells(iRow,iCol)<>Cells(iRow-1,iCol) Then... or If cells(iRow,iCol)<>Cells(iRow-1,iCol) And cells(iRow-1,iCol)="" Then....)
You match the criteria for your If-Clause.
Insert two rows/cells after (!) your current row (For i=1 To 2: Cells(iRow+1,iCol).Insert Shift:=xlDown: Next)

Ok. I tried below but it's taking very long...and got stuck...I believe something is going wrong...so is there a easy way to find non-blank cells in column A first and if it finds a non-blank cell then insert 2 cells below that non-blank cell..

Code:

---

Sub AddBlankRows()
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Range("A4")

iRow = oRng.Row
iCol = oRng.Column

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
Loop While Not Cells(iRow, iCol).Text = ""
End Sub

---

Huh?
Where do you start at the Bottom of your Column? you're still at the Top.
You're basically in an endless Loop, since you're not changing iRow to climb up

And in that case there is still either a iRow=iRow-1 missing or instead of the do-loop a
For LastRow to FirstRow Step-1

ok. I am selecting the end row in column A now... and i have removed the do loop but it's not running now..

Code:

---

Sub AddBlankRows()
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range
Dim i As Integer

Set oRng = Cells(Rows.Count, 1).End(xlUp).Row

iRow = oRng.Row
iCol = oRng.Column


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

End Sub

---

Untested!

Code:

---

Sub AddBlankRows()
'
Dim iRow As Long, iCol As Long
Dim oRng As Range
Dim LastRow As Long
Dim i As Integer

LastRow = Cells(Rows.Count, 1).End(xlUp).Row
iCol=1
For iRow=LastRow to 4 Step -1
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
Next
End Sub

---

Sorry...I want to loop from top to bottom actually and not bottom to top.. i also tried something like below but it's not working...

Code:

---

Sub Test()
Dim x As Integer
Dim y As Integer

y = 1
    For x = 4 To 10000
        If Cells(x, y).Value <> "" Then
          Cells(x + 1, y).Select
            Selection.Insert Shift:=xlDown
            Cells(x + 2, y).Select
            Selection.Insert Shift:=xlDown
           
            End If
    Next x

End Sub

---

but the above code shows error if i select more then 10000 rows plus i am unable to insert 2 rows at one go...with the above...can we run the below code to run from top to bottom and if it finds a cell with text (blank cells should be skipped) then it should insert 2 cells below that text cell.

Code:

---

Sub AddBlankRowsnew()
'
Dim iRow As Long, iCol As Long
Dim oRng As Range
Dim LastRow As Long
Dim i As Integer

LastRow = Cells(Rows.Count, 1).End(xlUp).Row
iCol = 1
For iRow = 4 To LastRow Step 1
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
Next
End Sub

---

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:

Code:

---

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

---