Help With VBA Code To Put Border Around Cells With Same Contents

[CVinje]

Hello, I've been able to find a couple macros posted elsewhere to accomplish what I'm looking for, but it does not work for all instances with items on the last row and was hoping somebody here could help me refine the macro or suggest an alternative solution. Here's the code:

Sub AddBorders()
    Dim startRow As Integer
    Dim iRow As Integer
    startRow = 1    
    For iRow = 2 To ActiveCell.CurrentRegion.Rows.Count    
        If WorksheetFunction.IsNumber(Cells(iRow + 1, 2)) Then
            If Cells(iRow, 2) <> Cells(iRow - 1, 2) Then
               AddBorder startRow, iRow - 1
               startRow = iRow
            End If
        Else
               AddBorder startRow, iRow
        End If   
    Next iRow    
End Sub


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


Sub AddBorder(startRow As Integer, endRow As Integer)
    Dim borderRange As Range
    Dim randomColor As Integer
    randomColor = Int((56 * Rnd) + 1)
    Set borderRange = Range("A" & startRow & ":D" & endRow)
    borderRange.BorderAround ColorIndex:=randomColor, Weight:=xlThick    
End Sub

The macro is from this URL for credit / reference: https://stackoverflow.com/questions/2976922/creating-a-border-around-cells-with-the-same-value

The macro works perfectly until I have smaller lists and certain conditions for items on the last row - it places the border around both the second to last items and the last item in the list as shown in the table below. The column the code is setup to work on is the Position column and the problem is that there will be a border around both the Emergency Coordinator and Mechanical Engineer row instead of separate borders for the short list below. For the longer list, even with two matching entries prior to the last entry, there will still be a border placed around the last 3 rows instead of an individual grouping border around the last row for OPS Manager. If the number of entries for the Position column increase, the problem resolves itself and borders are created appropriately. The intent is to have the list sorted by position A-Z and then have the border macro create the borders around like-names positions.

<tbody>
</tbody>

Location​	Position​	Contacted​
TSC​	Electrical Engineer​	Yes​
TSC​	Emergency Coordinator​	Yes​
TSC​	Mechanical Engineer​	Yes​

<tbody>
</tbody>

ALSO​

Location	Position	Contaced
TSC	Electrical Engineer	Yes
TSC	Emergency Coordinator	Yes
TSC	Mechanical Engineer	Yes
TSC	Mechanical Engineer	Yes
TSC	OPS Manager	Yes

<tbody>
</tbody>

I'm currently at work and unable to post image links but will try to get them up asap for further examples. Thank you very much for your time and any help!

CVinje

 

[CVinje]

Hello again - I've been able to solve my problem after finding an alternative method from another posting and making a couple modifications to suit my needs. Posting the solution I found here for anybody else looking.

Thank you!!

Sub Border()
Dim r1 As Byte, r2 As Byte
Dim lr As Long
Dim randomColor As Integer
'prime the loop
r1 = 1 'first row pointer
r2 = r1 'look-ahead row pointer
lr = Range("F2").End(xlDown).Row + 1 'the first row with
'a blank line, so the loop knows when to stop.
'loop only in the data, stop when a blank line encountered
Do While r1 < lr
  'figure out how many days are together
  Do While Cells(r2 + 1, 6).value = Cells(r1, 6).value
    r2 = r2 + 1
  Loop
  'draw border around similiar ranges using random color
  randomColor = Int((56 * Rnd) + 1)
  Range(Cells(r1, 1), Cells(r2, 20)).BorderAround _
    ColorIndex:=randomColor, Weight:=xlThick
  'prime for the next Do...Loop iteration
  r1 = r2 + 1
  r2 = r1
Loop
End Sub