excelvba

Merge cells and add borders

I'm trying to format a table in Excel that has two levels of merged cells.

I'm looking to:

  1. Merge cells that have the same value as the row below them in Column A, then put a border underneath it (thin, continuous, RBG code 153,153,153)
  2. Repeat this operation for Column B, but have the border extend 5 columns to the right
Level 1 Level 2 Tastiness Ripeness Tartness Sweetness Priciness
Fruits Apples 0.43 0.12 0.35 0.32 0.27
Fruits Pears 0.17 0.33 0.32 0.68 0.61
Fruits Pears 0.16 0.04 0.26 0.35 0.22
Fruits Strawberries 0.26 0.74 0.40 0.07 0.37
Fruits Strawberries 0.21 0.06 0.93 0.53 0.19
Fruits Strawberries 0.21 0.18 0.38 0.07 0.04
Fruits Strawberries 0.69 0.58 0.22 0.66 0.59
Fruits Strawberries 0.60 0.14 0.01 0.99 0.68
Fruits Strawberries 0.81 0.69 0.78 0.90 0.39
Vegetables Broccoli 0.29 0.32 0.31 0.46 0.77
Vegetables Broccoli 0.10 0.53 0.12 0.34 0.20
Vegetables Broccoli 0.28 0.97 0.02 0.45 0.84
Vegetables Broccoli 0.76 0.20 0.38 0.20 0.46
Vegetables Cauliflower 0.78 0.29 0.45 0.73 0.77
Vegetables Cauliflower 0.33 0.14 0.48 0.90 0.36
Vegetables Cauliflower 0.12 0.50 0.75 0.72 0.63

Desired output, with the NULLs having a bottom border and merged with the first cell.

Level 1 Level 2 Tastiness Ripeness Tartness Sweetness Priciness
Fruits Apples 0.43 0.12 0.35 0.32 0.27
NULL Pears 0.17 0.33 0.32 0.68 0.61
NULL NULL 0.16 0.04 0.26 0.35 0.22
NULL Strawberries 0.26 0.74 0.40 0.07 0.37
NULL NULL 0.21 0.06 0.93 0.53 0.19
NULL NULL 0.21 0.18 0.38 0.07 0.04
NULL NULL 0.69 0.58 0.22 0.66 0.59
NULL NULL 0.60 0.14 0.01 0.99 0.68
NULL NULL 0.81 0.69 0.78 0.90 0.39
Vegetables Broccoli 0.29 0.32 0.31 0.46 0.77
NULL NULL 0.10 0.53 0.12 0.34 0.20
NULL NULL 0.28 0.97 0.02 0.45 0.84
NULL NULL 0.76 0.20 0.38 0.20 0.46
NULL Cauliflower 0.78 0.29 0.45 0.73 0.77
NULL NULL 0.33 0.14 0.48 0.90 0.36
NULL NULL 0.12 0.50 0.75 0.72 0.63

The VBA code.

Sub merge_same_borders()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim rng As Range

For Each rng In Selection

    If rng.Value = rng.Offset(1, 0).Value And rng.Value <> "" Then
        Range(rng, rng.Offset(1, 0)).Merge
        Range(rng, rng.Offset(1, 0)).HorizontalAlignment = xlCenter
        Range(rng, rng.Offset(1, 0)).VerticalAlignment = xlCenter

    ElseIf rng.Value <> rng.Offset(1, 0).Value Then
        Range(rng, rng.Offset(0, 5)).Borders(xlEdgeBottom).Color = RGB(153, 153, 153)
        Range(rng, rng.Offset(0, 5)).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Range(rng, rng.Offset(0, 5)).Borders(xlEdgeBottom).Weight = xlThin
    End If
Next

Application.ScreenUpdating = True

End Sub
Solution

  • Microsoft documentation:

    Range.CurrentRegion property (Excel)

    Range.Resize property (Excel)

    Application.Union method (Excel)

    Option Explicit

Sub Demo()
    Dim oDic1 As Object, oDic2 As Object, rngData As Range
    Dim i As Long, sKey, ColCnt As Long, arrData
    Set oDic1 = CreateObject("scripting.dictionary")
    Set oDic2 = CreateObject("scripting.dictionary")
    Set rngData = Range("A1").CurrentRegion
    With rngData
        ColCnt = .Columns.Count - 2
        ' sort table
        .Sort Key1:=.Columns(1), Key2:=.Columns(2), Header:=xlYes
        ' load data into table
        arrData = .Value
    End With
    ' loop through data
    For i = LBound(arrData) + 1 To UBound(arrData)
        ' for Level 1
        sKey = arrData(i, 1)
        If oDic1.exists(sKey) Then
            Set oDic1(sKey) = Application.Union(oDic1(sKey), Cells(i, 1))
        Else
           Set oDic1(sKey) = Cells(i, 1)
        End If
        ' for Level 2
        sKey = arrData(i, 2)
        If oDic2.exists(sKey) Then
            Set oDic2(sKey) = Application.Union(oDic2(sKey), Cells(i, 2))
        Else
           Set oDic2(sKey) = Cells(i, 2)
        End If
    Next i
    Application.DisplayAlerts = False
    ' Level 1: merge
    For Each sKey In oDic1.Keys
        oDic1(sKey).Merge
    Next
    ' Level 2: merge and boarder
    For Each sKey In oDic2.Keys
        SetBorder oDic2(sKey).Offset(, 1).Resize(, ColCnt), False
        oDic2(sKey).Merge
    Next
    ' boarder for column A & B
    SetBorder rngData.Resize(rngData.Rows.Count - 1).Offset(1).Columns("A:B"), True
    Application.DisplayAlerts = True
End Sub

Sub SetBorder(rng As Range, bInside As Boolean)
    With rng.Borders
        .LineStyle = xlContinuous
        .Color = RGB(153, 153, 153)
        .Weight = xlThin
    End With
    If Not bInside Then
        rng.Borders(xlInsideVertical).LineStyle = xlNone
        rng.Borders(xlInsideHorizontal).LineStyle = xlNone
    End If
End Sub

    enter image description here