Merge cells with same year in a row

Question

I need to merge the cells one above the months. Cells Should be merged from 01 to 12 showing year in cell.

Look for the picture for more clarification. I have below code, but which show months after run in cell row1. My idea is to convert above cells to years through vba and apply merge same year at the end. which is shown in desired output.

Note. ROW 4 and 5 are just my thinking, which will help year to merge.

  Dim a(), i As Long, j As Long, m As Long, x As Range
  With Range("b1:qaz1")
    .MergeCells = False
    .ClearContents
    a() = .Offset(1).Value
    m = Month(a(1, 1))
    j = UBound(a, 2)
    Set x = .Cells(1)
    For i = 2 To j
      If m <> Month(a(1, i)) Or i = j Then
        With Range(x, .Cells(i - IIf(i = j, 0, 1)))
          .MergeCells = True
          .HorizontalAlignment = xlCenter
        End With
        x.Value = Format(DateSerial(2000, m, 1), "MMMM")
        m = Month(a(1, i))
        Set x = .Cells(i)
      End If
    Next
  End With
End Sub

After running new program output look like

Excel people all know that merging causes trouble. Consider re-phrasing your question to how to achieve the result you want without merging cells, and more people here will be interested in your topic. — Variatus

Variatus Variatus · Accepted Answer · 2020-05-24T02:26:33

Since you have true dates in your caption row the month and year can be extracted from there. However, the code below converts dates that might have been created using formulas to hard dates before processing them.

Sub MergeCaptionsByYear()
    ' 031

    Const CapsRow   As Long = 1                 ' change to suit
    Const StartClm  As Long = 2                 ' change to suit

    Dim Rng         As Range                    ' working range
    Dim Tmp         As Variant                  ' current cell's value
    Dim Cl          As Long                     ' last used column
    Dim Cstart      As Long                     ' first column in Rng
    Dim C           As Long                     ' working column
    Dim Yr          As Integer                  ' year

    Cl = Cells(CapsRow, Columns.Count).End(xlToLeft).Column
    Range(Cells(CapsRow, StartClm), Cells(CapsRow, Cl)).Copy
    Cells(CapsRow, StartClm).PasteSpecial xlValues
    Application.CutCopyMode = False

    C = StartClm - 1
    Application.DisplayAlerts = False
    Do
        Tmp = Cells(CapsRow, C + 1).Value
        If Not IsDate(Tmp) And (C <> Cl) Then
            MsgBox "Cell " & Cells(CapsRow, C + 1).Address(0, 0) & _
                   " doesn't contain a date." & vbCr & _
                   "This macro will be terminated.", _
                   vbInformation, "Invalid cell content"
            Exit Do
        End If

        If (Yr <> Year(CDate(Tmp))) Or (C = Cl) Then
            If Yr Then
                Set Rng = Range(Cells(CapsRow, Cstart), _
                                Cells(CapsRow, C))
                With Rng
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .NumberFormat = "yyyy"
                End With
                SetBorder Rng, xlEdgeLeft
                SetBorder Rng, xlEdgeRight
            End If
            If C > (Cl - 1) Then Exit Do
            Cstart = C + 1
            Yr = Year(Tmp)
        End If
        C = C + 1
    Loop
    Application.DisplayAlerts = True
End Sub

Private Sub SetBorder(Rng As Range, _
                      Bord As XlBordersIndex)
    ' 031

    With Rng.Borders(Bord)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium                          ' xlThin
    End With
End Sub

Merge cells with same year in a row

2 Answers