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

 

[Dratchsky]

Sub ApplyThickBordersBasedOnGroupID()
    Dim ws As Worksheet
    Set ws = ActiveSheet ' Set this to the appropriate worksheet, e.g., Sheets("Sheet1")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    
    Dim startRow As Long
    startRow = 2 ' Assuming your data starts at row 2
    
    Dim currentGroupID As Variant
    currentGroupID = ws.Cells(startRow, 2).Value
    
    Dim i As Long
    For i = startRow + 1 To lastRow + 1 ' Loop through each row, +1 to handle the last group
        If ws.Cells(i, 2).Value <> currentGroupID Or i = lastRow + 1 Then
            ' Apply border to the range from startRow to i-1
            With ws.Range(ws.Cells(startRow, 1), ws.Cells(i - 1, ws.Columns.Count)).Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
            With ws.Range(ws.Cells(startRow, 1), ws.Cells(i - 1, ws.Columns.Count)).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
            With ws.Range(ws.Cells(startRow, 1), ws.Cells(i - 1, ws.Columns.Count)).Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
            With ws.Range(ws.Cells(startRow, 1), ws.Cells(i - 1, ws.Columns.Count)).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
            
            ' Reset the start row and current Group ID
            startRow = i
            currentGroupID = ws.Cells(i, 2).Value
        End If
    Next i
End Sub