Please help with borders - VBA

[harrycosh]

I have the following macro, which applies a line where the text "Change" appears in column EE, and an ID number in column EF. It is fine if the "Change" text has more than a 3 row gap but if the text is in the row beneath it does not apply the line, or apply on the 2nd occurance. What am I doing wrong?

Sub ApplyingBorders()
Dim LSearchRow As Integer
 
On Error GoTo Err_Execute
'Start search in row 1
LSearchRow = 1
While Len(Range("EF" & CStr(LSearchRow)).Value) > 0
 
If Range("EE" & CStr(LSearchRow)).Value = "Change" Then
 
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
 
'Move counter to next row
LSearchRow = LSearchRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "Lines have been applied"
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub

Thanks