borders between 2 specific words

[pedy]

Hi all,

I have this bit of code that I need help with:


Code:
--------------------

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Dim lRow As Long
Dim LR1 As Long
Dim LR2 As Long
Dim LC As Long

With ActiveSheet.Cells
.Interior.ColorIndex = xlNone
.Borders.LineStyle = xlNone

On Error GoTo skip

.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone

LR1 = .Find("word1", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row + 1
LR2 = .Find("word2", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row - 1
LC = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious, False, False).Column

End With

lRow = 0

For lRow = LR1 To LR2 Step 1 'LR1 is "word1" - "LR2 is "word2"
With Range(Cells(lRow, 1), Cells(lRow, LC))
.Interior.ColorIndex = 24
With .Borders
For i = 7 To 11
With .Item(i)
.LineStyle = xlDot
'.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next i
End With
End With
Next lRow

skip:
If Err Then
MsgBox Err.Description, vbCritical, "ERROR"
End If

On Error GoTo 0

Application.ScreenUpdating = True

End Sub

--------------------


I am trying to is create borders around all cells in the range by
looking for 2 specific words to begin and end the borders. Let's say
word1 & word2. The border should begin after (under) word1 and end
before (above) word2. It will also happen that there will be several
occurrences of word1 & word 2 but it should only create the borders
between word1 & word 2 for every occurrence of those words.

Now this code seems to works but only for 1 occurrence of word1 & word2
(from the bottom up) and all the others are ignored

Can someone help please ?

Pedy