fastest way to merge duplicate cells in without looping Excel

Question

I have cells containing duplicate values that i want to merge quickly. The table looks like this:

Sub MergeCells()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant

ReDim arr(1 To 1) As Variant

With ThisWorkbook.Sheets("tst")
    Set Rng = .Range("A2:D11")
    lRow = Rng.End(xlDown).Row

    For J = 1 To 4
        For I = lRow To 2 Step -1   'last row to 2nd row
            If Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I - 1, J))) Then
                Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
                arr(UBound(arr)) = R.Address
                ReDim Preserve arr(1 To UBound(arr) + 1)
            End If
        Next I
    Next J
    ReDim Preserve arr(1 To UBound(arr) - 1)

    Set R = .Range(Join(arr, ","))
    'MsgBox R.Areas.Count
    'R.Select
    'R.MergeCells = True
    With R
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    Stop
End With

Application.DisplayAlerts = True
End Sub

The duplicate cells ranges could be disjointed or non-adjacent cells. I want a way to quickly identify such duplicate ranges and merge them without using a For loop. [Don't know, but think there could be a fastest innovative way without loops probably using some combination of Excel array formulae and VBA code, to select and merge duplicate cell ranges.]

BTW the above code works fine till it shoots up the following error at line .Merge.

EDIT This is a snapshot of the Watch window showing the arr content as well as R.Address.

OUTPUT: Don't need any selections, this is just for demonstration purpose:

Output should look like this:

EDIT... Suppose the duplicate values were same across the rows? So only duplicate columns values to be merged. There has to be an quick, innovative way to do this merge.

Final Output Image:

Answer 1

The issue is that your code can only find 2 adjacent cells and is not looking for a third one with this code: Set R = .Range(.Cells(I, J), .Cells(I - 1, J))

After the first loop it adds these 2 cells

After another loop it adds the next 2 cells

And this results in an overlapping

which you can see at the darker shading of the selection.

I just edited some part of your code with comments, so you can see how it could be done. But I'm sure there is still space for improvements.

Sub MergeCellsNew()
    Application.DisplayAlerts = False
    Dim n As Name
    Dim fc As FormatCondition
    Dim Rng As Range, R As Range
    Dim lRow As Long
    Dim I&, J&
    Dim arr As Variant

    ReDim arr(1 To 1) As Variant

    With ThisWorkbook.Sheets("tst")
        Set Rng = .Range("A2:D11")
        lRow = Rng.End(xlDown).Row

        For J = 1 To 4
            I = 2 'I = Rng.Row   to automatically start at the first row of Rng
            Do While I <= lRow
                Set R = .Cells(I, J) 'remember start cell

                'run this loop as long as duplicates found next to the start cell
                Do While Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I + 1, J)))
                    Set R = R.Resize(R.Rows.Count + 1) 'and resize R + 1
                    I = I + 1
                Loop

                'now if R is bigger than one cell there are duplicates we want to add to the arr
                'this way single cells are not added to the arr
                If R.Rows.Count > 1 Then
                    arr(UBound(arr)) = R.Address
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                I = I + 1
            Loop
        Next J
        ReDim Preserve arr(1 To UBound(arr) - 1)

        Set R = .Range(Join(arr, ","))
        With R
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Stop
    End With

    Application.DisplayAlerts = True
End Sub