Merge cells when cell value match (different column row value)

Question

I would like to write a Excel vba to merge cells according to their values and a reference cell in another column. Like the picture attached. I have over 18000 Lines, with many of variation. All the values within the line are in order rank.

enter image description here

This is the code that I based my VBA

Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False 
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:C10") 
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then 
Range(cell, cell.Offset(1, 0)).Merge
        GoTo MergeAgain
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 1

Edit Minor upgrade to allow merged ranges to be extended enabling merge updates.

Merge Vertically Adjacent Cells with Equal Values.

• Save in a regular module.
• Be sure the constants ( Const ) come before any other code in the module.
• Consider adding a guard to ensure this only runs against the worksheet
  it is intended for (see how to after the code).
• Run the macro from the Alt - F8 Macro Dialogue.
• NB Like most macros, this will wipe the Excel undo buffer.
  It cannot be undone with a Ctrl - Z . (The only options are to revert to last saved
  or manually edit to the way it was before.)

Copy/Paste

Private Const LastCol = 20
Private Const LastRow = 20

Public Sub Merge_Cells()
    Dim r As Range
    Dim s As Range
    Dim l As Range
    Dim c As Long
    Dim v As Variant
    
    For c = 1 To LastCol
        Set s = Nothing
        Set l = Nothing
        For Each r In Range(Cells(1, c), Cells(LastRow, c))
            v = r.MergeArea(1, 1).Value
            If v = vbNullString Then
                DoMerge s, l
                Set s = Nothing
                Set l = Nothing
            ElseIf s Is Nothing Then
                Set s = r
            ElseIf s.Value <> v Then
                DoMerge s, l
                Set s = r
                Set l = Nothing
            Else
                Set l = r
            End If
        Next r
        DoMerge s, l
    Next c
End Sub

Private Sub DoMerge(ByRef s As Range, ByRef l As Range)
    If s Is Nothing Then Exit Sub
    If l Is Nothing Then Set l = s
    Application.DisplayAlerts = False
    With Range(s, l)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Merge
    End With
    Application.DisplayAlerts = True
End Sub

Consider finding the last column and last row programmatically.

If the merge should start after row 1:

For Each r In Range(Cells(1, c), Cells(LastRow, c))
                          ^

• Change the 1 to the correct row number or replace with an added const variable.

To guard other worksheets, use the tab name (recommend renaming the tab first):

For Each r In Worksheets(TabName).Range(Cells(1, c), Cells(LastRow, c))
              ^^^^^^^^^^^^^^^^^^^^

• Make this edit to the same line as the starting row edit.
• And add Private Const TabName = "The Merge Tabs Name" ' Spaces ok
  to the top of the Module with the other Const (constants) .
• Or place the name directly in the code: Worksheets("The Merge Tabs Name") .

Answer 2

Add this into a module, select your range of data (excluding headers), run the macro and see if it works for you.

Public Sub MergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, strTopCell As String
    Dim strBottomCell As String, strThisValue As String, strNextValue As String
    Dim strThisMergeArea As String, strNextMergeArea As String

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            strTopCell = ""

            For lngRow = 1 To .Rows.Count
                If strTopCell = "" Then strTopCell = .Cells(lngRow, lngCol).Address

                strThisValue = .Cells(lngRow, lngCol)
                strNextValue = .Cells(lngRow + 1, lngCol)

                If lngCol > 1 Then
                    strThisMergeArea = .Cells(lngRow, lngCol - 1).MergeArea.Address
                    strNextMergeArea = .Cells(lngRow + 1, lngCol - 1).MergeArea.Address

                    If strThisMergeArea <> strNextMergeArea Then strNextValue = strThisValue & "."
                End If

                If strNextValue <> strThisValue Or lngRow = .Rows.Count Then
                    strBottomCell = .Cells(lngRow, lngCol).Address

                    With rngData.Worksheet.Range(strTopCell & ":" & strBottomCell)
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .MergeCells = True
                    End With

                    strTopCell = .Cells(lngRow + 1, lngCol).Address
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

There's one trick to this which is able to be changed and that is that it will also group based off the prior column. You can see an example of what I'm talking about in cell C19 ...

... it has worked out that the previous column had a grouping that stopped at that point, therefore, the 1 isn't carried through and grouped to the next lot, it stops and is grouped there. I hope that makes sense and I hope it gives you what you need.

Another thing, this code here will attempt to demerge all of your previously merged data.

Public Sub DeMergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, objCell As Range
    Dim objMergeArea As Range, strMergeRange As String, strFirstCell As String
    Dim strLastCell As String, objDestRange As Range

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            For lngRow = 1 To .Rows.Count
                Set objCell = .Cells(lngRow, lngCol)

                If objCell.Areas(1).MergeArea.Cells.Count > 1 Then
                    strMergeRange = objCell.Areas(1).MergeArea.Address

                    objCell.MergeCells = False

                    strFirstCell = Split(strMergeRange, ":")(0)
                    strLastCell = Split(strMergeRange, ":")(1)

                    Set objDestRange = .Worksheet.Range(.Worksheet.Range(strFirstCell).Offset(1, 0).Address & ":" & strLastCell)

                    .Worksheet.Range(strFirstCell).Copy objDestRange
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

A note, my suggestion is to ensure you have the original source data saved to another workbook/sheet as a backup before running any code over the top of it. If it stuffs with your data then it will be a right royal pain to undo manually.