Merge Across in selected cells adding certain number of cells to the right

Question

I made a VBA code already to select specific cells with certain values (Saturday). I want to merge across those selected cells, 4 cells to the right. Here's my code and a sample of my output.

Dim rng As Range
Set rng = Range("d12:h42, q12:u42")
With rng.Borders
    .LineStyle = xlContinuous
    .Color = vbBlack
    .Weight = xlThin
End With
Dim rCell As Range
Dim rng1 As Range
For Each rCell In Range("d12:h42, q12:u42")
If rCell.Value = "Saturday" Then
If rng1 Is Nothing Then
Set rng1 = rCell
Else
Set rng1 = Application.Union(rCell, rng1)
End If
End If
Next
rng1.Select
Application.DisplayAlerts = False
End Sub

Answer 1

Sub Demo()
    Dim rng As Range
    Set rng = Range("d12:h42, q12:u42")
    With rng.Borders
        .LineStyle = xlContinuous
        .Color = vbBlack
        .Weight = xlThin
    End With
    Dim rCell As Range
    Dim rng1 As Range
    Application.DisplayAlerts = False
    For Each rCell In Range("d12:h42, q12:u42")
        If rCell.Value = "Saturday" Then
            rCell.Resize(1, 4).Merge  '**
        End If
    Next
    Application.DisplayAlerts = True
End Sub