Adding Think Border Around Rows With Same Cell Value

[Dratchsky]

Hello,

This is my first post here. I was sure I would be able to find what I was looking for without posting however I didn't.

I would like to add a thick border around rows that share a common value

I have Column B titled Group ID and I would like to have a thick border placed around all the rows that share the same group ID

Below is a photo of the outcome I am looking for

 

[mumps]

Try:

Sub InsertBorder()
    Application.ScreenUpdating = False
    Dim lRow As Long, i As Long, v As Variant, lVisRow As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Range("A1").CurrentRegion.AutoFilter 2, v(i, 1)
                lVisRow = Cells(Rows.Count, "B").End(xlUp).Row
                Range("A1").AutoFilter
                Rows(lVisRow).Borders(xlEdgeBottom).Weight = xlMedium
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[Dratchsky]

Thank you so much!

Try:

Sub InsertBorder()
    Application.ScreenUpdating = False
    Dim lRow As Long, i As Long, v As Variant, lVisRow As Long
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Range("A1").CurrentRegion.AutoFilter 2, v(i, 1)
                lVisRow = Cells(Rows.Count, "B").End(xlUp).Row
                Range("A1").AutoFilter
                Rows(lVisRow).Borders(xlEdgeBottom).Weight = xlMedium
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Works like a gem!

 

[mumps]

You are very welcome.

 

[Rick Rothstein]

Here is another more compact way to write this macro...

Sub InsertBorder()
  Dim Cell As Range
  Application.ScreenUpdating = False
  For Each Cell In Range("B2", Cells(Rows.Count, "B").End(xlUp))
    If Cell.Value <> Cell.Offset(1).Value Then Cell.EntireRow.Borders(xlEdgeBottom).Weight = xlMedium
  Next
  Application.ScreenUpdating = True
End Sub