Warning Message

Sub MergeCells()
Dim c As Range, firstaddress As String, rng1 As Range, rng2 As Range
Dim I As Long, asht As Worksheet
Set asht = ActiveSheet
For I = 1 To 5
    Sheets("Week" & I).Activate
    Set rng1 = Sheets("Week" & I).Range("B4:H291")
    With rng1
        Set c = .Find("*")
        If Not c Is Nothing Then
            firstaddress = c.Address
            Do
                If c.Offset(1) = "" Then
                    If c.End(xlDown).Row <> Rows.Count Then
                        Set rng2 = Range(c, c.End(xlDown).Offset(-1))
                    Else
                        Set rng2 = Range(c, Cells(rng1.Cells(rng1.Cells.Count).Row, c.Column))
                    End If
                    With rng2
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .WrapText = True
                        .MergeCells = True
                    End With
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
    End With
    With rng1
        .Font.Size = 9
        .Font.Bold = True
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Color = RGB(100, 100, 100)
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Color = RGB(100, 100, 100)
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Color = RGB(100, 100, 100)
        End With
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Color = RGB(100, 100, 100)
        End With
    End With
Next I
asht.Activate
End Sub

Select allOpen in new window