Vba to merge Years in a row

[Liverlee]

Hello, I'm trying and failing to make a gantt chart.

I've linked A1 and b5, and the months increment with the edate(b5,1) dragged across. But the below VBA just doesn't like it nor will update the years and merge them.

Is it possible to amend the code below so it will auto amend & merge the years when cell A1 is updated with new date?

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

 

[Legacy 143009]

Like this maybe?

Sub test()
  Dim lastCol As Long
  lastCol = Cells(5, Columns.Count).End(xlToLeft).Column
  For i = 2 To 33
    For j = i + 1 To 34
      If Year(Cells(5, j + 1).Value) <> Year(Cells(5, j).Value) Then
        With Cells(4, i).Resize(1, j - i + 1)
          .Merge
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
        End With
        Cells(4, i).Value = Year(Cells(5, i).Value)
        i = j
        Exit For
      End If
    Next
  Next
End Sub

 

[Legacy 143009]

This code will update your table as soon as you update A1:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target = Range("A1") Then
    Application.EnableEvents = False
    Dim lastCol As Long
    lastCol = Cells(5, Columns.Count).End(xlToLeft).Column
    Range("B2").Resize(1, lastCol - 1).UnMerge
    For i = 2 To lastCol - 1
      For j = i + 1 To lastCol
        If Year(Cells(5, j + 1).Value) <> Year(Cells(5, j).Value) Then
          With Cells(4, i).Resize(1, j - i + 1)
          .Merge
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          End With
          Cells(4, i).Value = Year(Cells(5, i).Value)
          i = j
          Exit For
        End If
      Next
    Next
    Application.EnableEvents = True
  End If
End Sub

 

[kvsrinivasamurthy]

Try

Sub MergeCells()
Dim stcel$, Lc&, T&
stcel = "B4"
Lc = Range("b5").End(xlToRight).Column
With Range("B4").EntireRow
.UnMerge
.Clear
End With
For T = 2 To Lc
If Year(Range(stcel).Offset(1, 0)) <> Year(Cells(5, T + 1)) Then
    With Range(stcel & ":" & Cells(4, T).Address)
    .Merge
    .HorizontalAlignment = xlCenter
    .Value = Year(Range(stcel).Offset(1, 0))
    End With
stcel = Cells(4, T + 1).Address

End If
Next T
End Sub

 

[Liverlee]

Thank you for both replying to my query and providing solutions. Much appreciated