Merge all duplicate cells in entire worksheet - Excel VBA - excel

Question

I'm trying to build a macro which will iterate through Activeworkbook/Activeworksheet& Range("A1:" & LastColumn & LastRow) and merge all duplicates in each column. The best starting point I could find was this post --> fastest way to merge duplicate cells in without looping Excel
But, like the OP comments on #PEH's answer https://stackoverflow.com/a/45739951/5079799 I get the following error Application defined error on the line Set R = .Range(Join(arr, ",")).
Does anybody have the fix and/or a better/alternative way to merge duplicates in a column?
Code from answer:
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

Answer 1

The problem I see with the methods outlined above is that it relies on duplicate data existing in an adjacent cell in the column. What if the duplicates are scattered in the column?
Here's an example where each column is examined by creating a Dictionary of all the values. Since each value must be unique (as the Key), then duplicates are removed with a list of just the unique Keys. Then it's just a matter of clearing the column of the previous data and copying the unique data back to the worksheet.
Option Explicit
Sub RemoveColumnDupes()
Dim lastCol As Long
With Sheet1
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Dim c As Long
For c = 1 To lastCol
Dim columnDict As Dictionary
Set columnDict = CreateColumnDictionary(Sheet1, c)
If columnDict is Nothing then Exit For
'--- clear the existing data and replace with the cleaned up data
.Range("A1").Offset(, c - 1).Resize(.Rows.Count, 1).Clear
.Range("A1").Offset(, c - 1).Resize(columnDict.Count, 1) = KeysToArray(columnDict)
Next c
End With
End Sub
Private Function CreateColumnDictionary(ByRef ws As Worksheet, _
ByVal colIndex As Long) As Dictionary
Dim colDict As Dictionary
Dim lastRow As Long
With ws
lastRow = .Cells(.Rows.Count, colIndex).End(xlUp).Row
If lastRow = 1 Then
'--- can't create a dictionary with no data, so exit
Set colDict = Nothing
Else
Set colDict = New Dictionary
Dim i As Long
For i = 1 To lastRow
If Not colDict.Exists(.Cells(i, colIndex).Value) Then
colDict.Add .Cells(i, colIndex).Value, i
End If
Next i
End If
End With
Set CreateColumnDictionary = colDict
End Function
Private Function KeysToArray(ByRef thisDict As Dictionary) As Variant
Dim newArray As Variant
ReDim newArray(1 To thisDict.Count, 1 To 1)
Dim i As Long
For i = 1 To thisDict.Count
newArray(i, 1) = thisDict.Keys(i - 1)
Next i
KeysToArray = newArray
End Function

Answer 2

While I don't know the issue with the code I found and posted in OP. I did find awesome solutions on https://www.extendoffice.com and modified it to suit my needs as found below.
Test:
Sub MergeTest()
Dim wsrng As Range
Set wsrng = ActiveSheet.UsedRange
Call MergeWS(wsrng)
'Call UnMergeWS(wsrng)
End Sub
Merge:
https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html
Function MergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
UnMerge:
https://www.extendoffice.com/documents/excel/1139-excel-unmerge-cells-and-fill.html
Function UnMergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
xTitleId = "KutoolsforExcel"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Rng In WorkRng
If Rng.MergeCells Then
With Rng.MergeArea
.UnMerge
.Formula = Rng.Formula
End With
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
https://www.freesoftwareservers.com/display/FREES/Merge+and+UnMerge+cells+-+Excel+VBA