Is this what you need?
Sub rowsinsert()
For i = Cells(Rows.Count, "a").End(xlUp).Row To 6 Step -1
If InStr(Cells(i, "a"), "01152") Then
'MsgBox i
Rows(i).Insert
Cells(i, "a") = "Next"
End If
Next i
End Sub
before
1
2
01152
1
2
01152
1
2
01152

after
1
2
Next
01152
1
2
Next
01152
1
2
Next
01152


--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"pwk" wrote in message
...
Why won't this stop looping? Where did I go wrong. It works fine but
it goes on and on.
thanks in Advance

Public Sub RowFix()

Dim c As Variant
Dim FirstRow As Integer

With Worksheets(1).Range("A6:A4000")
Set c = .Find("01152", LookIn:=xlValues)
If Not c Is Nothing Then
FirstRow = c.Row + 1
Do Until IsEmpty(ActiveCell)
c.EntireRow.Insert
c.Offset(-1, 0).Value = "Next"
Set c = .FindNext(c)
Loop
End If
End With

End Sub