excel - How do you merge same value columns using vba?

Question

Can anyone help me write a vba code to merge same value cells in different columns as shown below.

I have tried using the code below but doesn't work;

Sub mergeWeeks()
    Dim lc As Long, nc As Long, cr As Long, rng As Range

    Application.DisplayAlerts = False

    With Worksheets("sheet2")
        For cr = 1 To 2
            lc = Application.Match("zzz", .Rows(cr))
            Set rng = .Cells(cr, 1)
            Do While rng.Column < lc
                nc = Application.Match(rng.Value & "z", .Rows(cr))
                rng.Resize(1, nc - rng.Column + 1).Merge
                Set rng = rng.Offset(0, 1)
            Loop
        Next cr
    End With

    Application.DisplayAlerts = True

End Sub

Answer 1

Using Range.Find with xlPrevious should wrap around the worksheet row to find the last occurrence of a value.

Option Explicit

Sub mergeSame()

    Dim r As Long, c As Long, c2 As Long

    r = 3   'row with 'Year'
    c = 1   'column with 'Year'

    With Worksheets("sheet3")

        Do While Not IsEmpty(.Cells(r, c))
            c2 = .Rows(r).Cells.Find(What:=.Cells(r, c).Value, After:=.Cells(r, c), _
                                     MatchCase:=False, LookAt:=xlWhole, _
                                     SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
            If c2 > c Then
                With .Cells(r, c).Resize(2, 1)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                End With
                With .Range(.Cells(r, c), .Cells(r, c2))
                    Application.DisplayAlerts = False
                    .Offset(1, 0).Merge
                    .Merge
                    Application.DisplayAlerts = True
                End With
            End If

            c = c2 + 1
        Loop

    End With

End Sub