borders between 2 specific words

Hi all,

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

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

Pedy,

Your .Find statements are using xlPrevious, which means that they search backwards through the range. This is the reason it is always the 'last' pair that get affected.
Also there is no looping in the macro above, (other than to colour & border the rows of a single pair), which is why it does not operate on any other pairs. Try the code below, I have tried to explain it in comments, but please ask if there is anything you are unsure about:

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

'Dim lRow As Long
'Dim LR1 As Long  Now using the 'word1' range instead
'Dim LR2 As Long  Now using the 'word2' range instead
Dim LC As Long
Dim word1 As Range
Dim word2 As Range
Dim word1_first_addr
Dim word2_first_addr
    
' Stop screen flicker
Application.ScreenUpdating = False

' Clear old formatting
With ActiveSheet.Cells
    .Interior.ColorIndex = xlNone
    .Borders.LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
 
    ' Find the last column used
    LC = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, lookat:=xlPart, searchdirection:=xlPrevious, searchorder:=xlByColumns).Column
    
    ' Find our first 'pair' of words
    Set word1 = .Find(what:="word1", after:=.Cells(1, 1), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows)
    Set word2 = .Find(what:="word2", after:=.Cells(1, 1), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows)

    ' As long as we found both words, carry on
    If Not word1 Is Nothing And Not word2 Is Nothing Then
        ' Record the cell row & column address for each of the words, so that we know where we started
        word1_first_addr = word1.Address
        word2_first_addr = word2.Address
        Do
            With Range(.Cells(word1.Row + 1, 1), .Cells(word2.Row - 1, LC))
                ' Apply the colouring
                .Interior.ColorIndex = 24
                ' Apply the borders
                With .Borders
                    .LineStyle = xlDot
                    .ColorIndex = xlAutomatic
                End With
            End With
            ' Search for a pair of words again, AFTER the occurance we just dealt with
            Set word1 = .Find(what:="word1", after:=word1, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows)
            Set word2 = .Find(what:="word2", after:=word2, LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows)
        ' If we find a pair, and they aren't at the same address as the very first pair we found then repeat the loop.
        Loop While Not word1 Is Nothing And word1.Address <> word1_first_addr And _
                   Not word2 Is Nothing And word2.Address <> word2_first_addr
      
    End If
End With

Application.ScreenUpdating = True

End Sub

Incidently why do you have the macro in the selection change macro? This means it runs every time you move the cursor on the sheet, clearing all the formatting and redoing it...

No worries. If this solves the case please mark the thread as Solved;

Edit your first post, click [Go Advanced].
In the prefix dropdown box select 'Solved'.

Pedy, Are you able to upload an example workbook as this would make it much clearer.
Perhaps one sheet of example input data, and one sheet with an example of what you want as an output?

Before:

Empty cell
	
Header 1
	
Empty cell
	
Word1 (A4)	
      (A5) | 4 / 8 – 10
      (A6) | 2 / 8 – 10
      (A7) | 4 / 8 – 10 
      (A8) | 5 / 8 – 10 b
Word2 (A9)

Empty cell
	
Header 2
	
Empty cell
	
Word1 (A13)	
      (A14) | 4 / 8 – 10
      (A15) | 7 / 8 – 10 f
      (A16) | 2 / 8 – 10
Word2 (A17)

After:

Empty cell
																
Header 1
																
Empty cell

Word1 (A4) | On / Off (next to word1) | Out ((cell C3)1st 'Out' not paired in loop) | In (D3 (1st pair in loop)) | Out (E3(pair in loop)) | In (F3) | Out (G3) | In (H3) | Out (I3) | In (J3) | Out (K3) | In (L3) | Out (M3) | In (N3) | Out (O3) | In (P3) | Out (Q3) | 
      (A5) | 4 / 8 – 10															
      (A6) | 2 / 8 – 10															
      (A7) | 4 / 8 – 10 															
      (A8) | 5 / 8 – 10 b															
Word2 (A9)

Empty cell

Header 2																
Empty cell

Word1 (A13) | On / Off (next to word1) | Out ((cell C3)1st 'Out' not paired in loop) | In (D3 (1st pair in loop)) | Out (E3(pair in loop)) | In (F3) | Out (G3) | In (H3) | Out (I3) | In (J3) | Out (K3) | In (L3) | Out (M3) | In (N3) | Out (O3) | In (P3) | Out (Q3) | 
      (A14) | 4 / 8 – 10															
      (A15) | 7 / 8 – 10 f (is the highest value)															
      (A16) | 2 / 8 – 10															
Word2 (A17)

In this example 7 is the highest value (1st number in the cell) found in the column so the paired 'In' 'Out' loop will be inserted 7 times (7 'In' and 7 'Out').

Pedy