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

Merge in Rows

Links

Workbook Download: "how-do-you-merge-same-value-columns-using-vba_54279695.xls"

Another 3D Array Example on SO: Array of Arrays feat. 3-dimensional Jagged Arrays

Features

• The worksheet parameter (cSheet) can be entered as name or index.
• You can add as many (un)contiguous rows as you like (cRows). The Trim function insures correct functionality even if there are (accidental) spaces between commas and row numbers.
• The first column can be entered as letter or number (cFirstC) while the last column (LastC) is being calculated in the first row.
• Range Union (rngU) in MERGE and the 3D array of arrays (vntAA) in UNMERGE should ensure great efficiency.

Merge Union Version

Sub MergeInRows()

    Const cSheet As Variant = "Sheet2"  ' Worksheet Name/Index
    Const cRows As String = "1,2"       ' Merge Rows List
    Const cFirstC As Variant = "B"      ' First Column Letter/Number

    Dim rngU As Range     ' Union Range
    Dim vntR As Variant   ' Merge Rows Array
    Dim LastC As Long     ' Last Column
    Dim CurrR As Long     ' Current Row
    Dim i As Long         ' Rows Counter
    Dim j As Long         ' Columns Counter

    Application.DisplayAlerts = False

    vntR = Split(cRows, ",")

    With ThisWorkbook.Worksheets(cSheet)
        LastC = .Rows(CLng(Trim(vntR(0)))).Find("*", , -4123, , 1, 2).Column
        For i = 0 To UBound(vntR)
            CurrR = CLng(Trim(vntR(i)))
            Set rngU = .Cells(CurrR, cFirstC)
            For j = .Cells(1, cFirstC).Column + 1 To LastC
                If .Cells(CurrR, j) = .Cells(CurrR, j - 1) Then
                    Set rngU = Union(rngU, .Cells(CurrR, j))
                  Else
                    With rngU
                        .Merge
                    End With
                    Set rngU = .Cells(CurrR, j)
                End If
            Next
            If rngU.Columns.Count > 1 Then rngU.Merge
        Next

    End With

    Application.DisplayAlerts = True

End Sub

UnMerge 3D Array Version

Sub UnMergeInRows()

    Const cSheet As Variant = "Sheet2"  ' Worksheet Name/Index
    Const cRows As String = "1,2"       ' Merge Rows List
    Const cFirstC As Variant = "B"      ' First Column Letter/Number

    Dim CurrRng As Range  ' (Current) Merge Row Range
    Dim vntR As Variant   ' Merge Row Array
    Dim vntAA As Variant  ' Merge Range Arrays Array
    Dim vntT As Variant   ' Temporary AA Container
    Dim LastC As Long     ' Last Column
    Dim CurrR As Long     ' Current Row
    Dim i As Long         ' Merge Row- and Merge Range Arrays- Array Row Counter
    Dim j As Long         ' Border Row- and Merge Range Arrays- Array Columns Counter

    Application.DisplayAlerts = False

    vntR = Split(cRows, ",")
    ReDim vntAA(UBound(vntR))

    With ThisWorkbook.Worksheets(cSheet)
        LastC = .Rows(CLng(Trim(vntR(0)))).Find("*", , -4123, , 1, 2).Column
        LastC = LastC + .Cells(CLng(Trim(vntR(0))), LastC) _
                .MergeArea.Columns.Count - 1
        ' Copy Merge Row Ranges to Merge Range Arrays Array.
        For i = 0 To UBound(vntR)
            CurrR = CLng(Trim(vntR(i)))
            Set CurrRng = .Range(.Cells(CurrR, cFirstC), .Cells(CurrR, LastC))
            With CurrRng
                ' Apply formatting to (Current) Merge Row Range.
                .UnMerge
                For j = 7 To 11
                    With .Borders(j)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                Next
            End With
            ' Copy (Current) Merge Row Range to Merge Range Arrays Array.
            vntAA(i) = CurrRng
        Next

        ' Manipulate data in Merge Range Arrays Array.
        For i = 0 To UBound(vntR)
            vntT = vntAA(i)(1, 1)
            For j = 2 To UBound(vntAA(i), 2)
                If vntAA(i)(1, j) = "" Then
                    vntAA(i)(1, j) = vntT
                  Else
                    vntT = vntAA(i)(1, j)
                End If
            Next
        Next

        ' Copy Merge Range Arrays to Merge Ranges.
        For i = 0 To UBound(vntR)
            .Cells(CLng(Trim(vntR(i))), cFirstC) _
                    .Resize(, UBound(vntAA(i), 2)) = vntAA(i)
        Next

    End With

    Application.DisplayAlerts = True

End Sub

Answer 2

merge cells horizontally, when value identical

Sub mergeCells()
    Dim ws As Worksheet
    Dim UsedColumns As Long
    Dim rng As Range
    Dim CurrentRow As Long, CurrentColumn As Long

    Set ws = ActiveWorkbook.Worksheets("sheet3")
    UsedColumns = ws.Cells.Find(What:="*", LookIn:=xlFormulas, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Application.DisplayAlerts = False

    For CurrentRow = 1 To 2
        For CurrentColumn = UsedColumns To 2 Step -1
            Set rng = ws.Cells(CurrentRow, CurrentColumn)
            If rng.Value <> "" And rng.Value = rng.Offset(0, -1).Value Then
                rng.Offset(0, -1).Resize(1, 2).Merge
            End If
        Next CurrentColumn
    Next CurrentRow
    Application.DisplayAlerts = True

    set rng = Nothing
    Set ws = Nothing
End Sub

merge cells horizontally, when month identical

If it's enough to compare the values (e. g. each "jan" is just the same string), then the code above works.
If the month is based on a cell format of different dates (e. g. dec 1st, dec 8th, dec 15th ... all shown as "dec" or "12"), then you can compare Month(rng.Value) with Month(rng.Offset(0, -1).Value).

Unmerge

Sub UnmergeCells()
    Dim ws As Worksheet
    Dim UsedColumns As Long
    Dim rng As Range
    Dim cellcount As Long
    Dim CurrentRow As Long, CurrentColumn As Long

    Set ws = ActiveWorkbook.Worksheets("sheet3")
    UsedColumns = ws.UsedRange.Cells(1).Column + ws.UsedRange.Columns.Count - 1

    For CurrentRow = 1 To 2
        For CurrentColumn = 1 To UsedColumns
            Set rng = ws.Cells(CurrentRow, CurrentColumn)
            If rng.Value <> "" And rng.MergeCells Then
                cellcount = rng.MergeArea.Cells.Count
                rng.MergeArea.UnMerge
                rng.Resize(1, cellcount).Value = rng.Value
            End If
        Next CurrentColumn
    Next CurrentRow

    Set rng = Nothing
    Set ws = Nothing
End Sub

As Range.Find is bad in finding the last used column, if it's within merged cells. So I use the standard UsedRange instead to find it even when cells are merged.

Answer 3

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