Need to add row based on column value

[kfr]

I need to add blank rows to a sheet as long as the text in column d is not
the same; I want those without a row between. I have used this macro to put
row in but don’t know where to add the additional coding to not put in the
additional row. Ex: what I want it to look like

(COL A) (COL B) (COL C) (COL D)
Test a Test b Test c Test d

Group a Group b Group c Group d
Group a Group b Group c Group d

My data a My data b My data c My data d

New info a New info b New info c New info d



Current Macro

Sub InsertBlankRow()
For r = Cells(Rows.Count, "E" <>).End(xlUp).Row To 2 Step -1
Rows(r).Insert Shift:=xlDown
Next r
end sub

Thanks

 

[JLGWhiz]

Give this a try.

Sub rwInst()
Dim lr As Long, sh As Worksheet
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, "D").End(xlUp).Row
For i = lr To 2 Step -1
If sh.Cells(i, "D") <> "" Then
If sh.Cells(i - 1, "D").Value <> "" And sh.Cells(i, "D").Value _
<> sh.Cells(i - 1, "D").Value Then
sh.Cells(i, "D").EntireRow.Insert
End If
End If
Next
End Sub

 

[kfr]

that worked- you da bomb

thanks much
--
kfr

Give this a try.

Sub rwInst()
Dim lr As Long, sh As Worksheet
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, "D").End(xlUp).Row
For i = lr To 2 Step -1
If sh.Cells(i, "D") <> "" Then
If sh.Cells(i - 1, "D").Value <> "" And sh.Cells(i, "D").Value _
<> sh.Cells(i - 1, "D").Value Then
sh.Cells(i, "D").EntireRow.Insert
End If
End If
Next
End Sub