fastest way to merge duplicate cells in without looping Excel - 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