If I understand what you want to do correctly you are trying to find all
instances of 200611 and insert a blank row after them??? If so give this a
try...

Dim rngFound As Range
Dim strFirstAddress As String
Dim strFindString As String

strFindString = "200611"

With ActiveSheet.Range("B:B")
Set rngFound = .Find(What:=strFindString, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If Not rngFound Is Nothing Then
'Application.Calculation = xlCalculationManual
strFirstAddress = rngFound.Address
Do
rngFound.Offset(1, 0).EntireRow.Insert
Set rngFound = .FindNext(rngFound)
Loop Until rngFound.Address = strFirstAddress
'Application.Calculation = xlCalculationAutomatic
End If
End With

If the performance of this is kinda slow then you may want to suspend
calculations while it is running (uncomment the lines)
--
HTH...

Jim Thomlinson


"shorticake" wrote:

I'm having difficulty getting this macro to loop. I keep getting the run
time error 1004, or the macro will continue to insert rows until it reaches
the last available row in the sheet.

Any help or suggestions are greatly appreciated.

Dim i As Integer
Dim Rng As Range
Dim lFirstRow As Long
With ActiveSheet.Range("B:B")

Dim findstring As String
findstring = "200611"

Set Rng = Range("B:B").Find(What:=findstring, After:=Range("B" &
Rows.Count), LookIn:=xlValues, LookAt:=xlWhole)
If Not Rng Is Nothing Then
lFirstRow = Rng.Row
Do
With Rng.Offset(1, 0)
For i = 1 To 1
.EntireRow.Insert xlShiftDown
Next i
End With
Set Rng = .FindNext(Rng)

Loop While Not Rng Is Nothing

End If
End With

End Sub