Not tested but try this

Sub Abbey3()

Dim cell As Range
Dim FirstCell As String

Set cell = Cells.Find(What:="Total for Department", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).Activate

If Not cell Is Nothing Then

FirstCell = cell.Address

Do

Rows(cell.Row + 1).Insert
Set cell = Cells.FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = FirstCell
End If

End Sub



--
---
HTH

Bob


(there's no email, no snail mail, but somewhere should be gmail in my addy)



"mike_vr" wrote in message
...
Hi there, wonder if anyone can help. Relatively new to loops, and can't
get
it to stop looping!!

Here's the code, trying to insert a row after every cell that has "Total
for
department" (number of occurences vary each time), and whilst the row gets
added, it then loops back to the beginning and adds multiple rows.

Any thoughts?

Thanks, Mike

Sub Abbey3()

Dim i As Integer
Dim thisrow As Integer

For i = 1 To Selection.CurrentRegion.Rows.Count - 1

Cells.Find(What:="Total for Department", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate

thisrow = Selection.Row
Rows(thisrow + 1).EntireRow.Insert

ActiveCell.Offset(1, 0).Select

Next i

End Sub