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

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.