Merge cells with same year in a row - excel

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

Answer 1

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

Answer 2

Assuming the months range is "B5:AH5"
Sub test()
Dim monthsRng As Range
Set monthsRng = Range("B5:AH5")
monthsRng.Cells(1, 1).Offset(-1, 0).Select
For j = 1 To Int((monthsRng.Cells.Count / 12) + 2)
If ActiveCell.Offset(1, 0) <> 0 Then
For i = 1 To 12
ActiveCell.Value = Year(ActiveCell.Offset(1, 0))
If Year(ActiveCell.Offset(1, i)) = ActiveCell Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
With Selection
.HorizontalAlignment = xlCenter
.MergeCells = True
End With
Selection.Offset(0, 1).Select
Else
Exit For
End If
Next
End Sub
Replacing the inner for loop with below code will work irrespective of whether the dates in the Range("B5:AH5") in above procedure are formatted as dates or not.
For i = 1 To 12
ActiveCell.Value = Right(Format(ActiveCell.Offset(1, 0), "DD.MM.YYYY"), 4)
If Right(Format(ActiveCell.Offset(1, i), "DD.MM.YYYY"), 4) = Format(ActiveCell, Text) Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
However, in any case you need to format the output in excel as number (without 1000 separator and decimal places) and not date.