Search code examples
excelvba

VBA function to merge cells and add borders

I'm trying to format a table in Excel that has two levels of merged cells. I've been merging cells that are the same manually, but the size has recently increased so much that this is no longer possible. I'm quite new to VBA, so any help is appreciated. 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 I've been working on is shown below. Thanks for any help or advice!

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
    • Using two Dict objects to collect the cells of Level1 and Level2
    • Interating Dict object to merge cells and set boarders

    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