Discuss "Break & Continue in VB (Excel)" in the Microsoft Office forum.

Sub linereplace()

Dim recno As Integer
recno = 1

Dim checktext As String
Dim EndofLine As String
Dim BoxCheck As String
Dim IsEndOfLine As Boolean
IsEndOfLine = False 'Initialize variable to False... we'll change it when needed.

Range("A65536").Select 'This is the presumed end of the worksheet
Selection.End(xlUp).Select

Dim LastRow As Integer
LastRow = ActiveCell.Row

Dim MaxRecord As Integer
MaxRecord = LastRow * 3

'First delete any data in columns other than A
Columns("B:IV").Select
Selection.Delete

'Remove blank lines sub:
RemoveBlankLines

Range("A1").Select 'Ensures that A1 is the start point

Do Until recno = MaxRecord
 
checktext = Range("A" & recno)
checktext = Strings.Trim(checktext)
checktext = Strings.Replace(checktext, "-", "")
 
Dim EvalArr As Variant
EvalArr = Split(checktext, " ", , vbTextCompare)

On Error Resume Next

Dim MaxArr As Variant
MaxArr = UBound(EvalArr)

'the last item in the line must be numeric
If IsNumeric(EvalArr(MaxArr)) Then
    IsEndOfLine = True
End If

If Len(EvalArr(MaxArr)) > 9 Or Len(EvalArr(MaxArr)) < 5 Then
    IsEndOfLine = False
End If

If IsEndOfLine = True Then
    Dim iCount As Integer
    iCount = 0

    For iCount = 0 To MaxArr
    Dim s As String
    s = EvalArr(iCount)

    If Strings.LCase(s) = "box" Or Strings.LCase(s) = "pmb" Then
        IsEndOfLine = False
        Exit For
    End If
    Next
End If

If IsEndOfLine = True Then
    Dim NewCell As String
    NewCell = Range("A" & (recno + 1))
    If Not NewCell = "" Then
        Rows(recno + 1 & ":" & recno + 1).Select
        Selection.Insert shift:=xlDown
    End If 'Evaluate New Cell Contents
End If 'Is this the end of the line?
recno = recno + 1
Loop
 
End Sub

Private Sub RemoveBlankLines()
'Select the last row then move up to the last row where data is found.
Range("A65536").Select
Selection.End(xlUp).Select

Do Until ActiveCell.Row = 1
Dim i As Integer

Selection.End(xlUp).Select
i = ActiveCell.Row

Dim RemoveRow As Integer
RemoveRow = i - 1
If RemoveRow < 1 Then Exit Do

Rows(RemoveRow & ":" & RemoveRow).Select
Selection.Delete shift:=xlUp

Loop 'End remove extra spaces loop

End Sub