VBA: Loop through merged cells and apply formatting for alternate rows

Question

I've used VBA to filter out values from a different sheet and I'm thinking of how best to format it for readability. I've merged similar values and would like to select the corresponding rows for each alternating merged cell and apply a color fill.

Here is a visual for reference:

And this is the code I've used to get to the current state.

Dim lRow As Long
lRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.DisplayAlerts = False
For i = lRow To 7 Step -1
    If Cells(i, 2) = Cells(i - 1, 2) Then
        Range(Cells(i, 2), Cells(i - 1, 2)).Merge
    End If
Next i
Application.DisplayAlerts = True

Is there a way of inserting formatting within the loop or otherwise? I'm also open to other ways of making the table more readable.

PS: The image I've attached is just for reference. The actual table I'm working with has tons of rows and columns so readability is important.

Answer 1

Except for the merging of cells the code below does what you want. Instead of merging the code effectively hides the duplicate item titles.

Option Explicit

Sub FormatData()
    ' 28 Feb 2019

    Const CaptionRow As Long = 1
    Const FirstDataRow As Long = 3              ' assuming row 2 to contain subtitles
    Const FirstDataClm As String = "B"          ' change as appropriate
    Const DescClm As String = "D"               ' change as appropriate

    Dim Desc As Variant, PrevDesc As Variant
    Dim Col() As Variant, ColIdx As Boolean
    Dim FontCol As Long
    Dim Rng As Range
    Dim Rl As Long, Cl As Long                  ' last Row / Column
    Dim R As Long

    Rl = Cells(Rows.Count, DescClm).End(xlUp).Row
    Cl = Cells(CaptionRow, Columns.Count).End(xlToLeft).Column
    Col = Array(15261367, 15986394)             ' sky, pale: change as required
    FontCol = Cells(FirstDataRow, FirstDataClm).Font.Color
    Application.ScreenUpdating = False

    For R = FirstDataRow To Rl
        Desc = Cells(R, DescClm).Value
        If Desc = PrevDesc Then
            Set Rng = Rng.Resize(Rng.Rows.Count + 1)
        Else
            If Not Rng Is Nothing Then
                SetColouring Rng, DescClm, Col(Abs(ColIdx)), FontCol
                ColIdx = Not ColIdx
            End If
            Set Rng = Range(Cells(R, FirstDataClm), Cells(R, Cl))
        End If
        PrevDesc = Desc
    Next R

    SetColouring Rng, DescClm, Col(Abs(ColIdx)), FontCol
    Application.ScreenUpdating = True
End Sub

Private Sub SetColouring(Rng As Range, _
                         ByVal C As String, _
                         ByVal Col As Long, _
                         ByVal Fcol As Long)
    ' 28 Feb 2019

    Dim R As Long

    With Rng
        .Interior.Color = Col
        .Font.Color = Fcol
        For R = 2 To .Rows.Count
            .Cells(R, Columns(C).Column - .Column + 1).Font.Color = Col
        Next R
    End With
End Sub

There are some constants at the top of the code which you can modify. Note also that the font color you use in the sheet is presumed to be found in the first used cell of the sheet as specified by the constants.

Observe that the entire code runs on the ActiveSheet . I strongly urge you to change that bit and specify a sheet, preferably both by its name and the workbook it is in. If you regularly use the code as published above its just a matter of time before you apply it to a worksheet which gets damaged as a result.