Merge Cells with Duplicate Data VBA - vba

Question

I'm trying to get a Macro working to merge cells with duplicate data. It will work on small numbers of cells, but I get the following error if I try to run it on a larger group of cells. I'm not sure if there's a more efficient way for excel to run through this.
Run-Time error '1004':
Method 'Range' of object '_Global' failed
Here's the code:
Sub MergeDuplicates()
Dim varData As Variant, varContent As Variant
Dim strMyRange As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMyRange = ActiveCell.Address
varContent = ActiveCell.Value
For Each varData In Selection.Cells
If varData.Value <> varContent Then
strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address
varContent = Cells(varData.Row, varData.Column).Value
End If
Next
strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address))
Range(strMyRange).Merge
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 1

I have recreated the issue using the code you posted and it is working for me. I did what you suggested and put the merge into the For loop. Then I split strMyRange using the comma as the delimiter. I set up a test to look for the ":" character in TestArray(0). If it is in that target string, then I know it is ready for the merge. After that I reset strMyRange to the TestArray(1) which is the beginning of the next range.
Note: I was able to step through it with the debugger with 100 cells and it worked. Then I tried running it without any code breakpoints, but it merged all the selected cells. I put a 1 second wait statement right before the final merge and that seems to work.
Here is the code:
Sub MergeDuplicates()
Dim varData As Variant, varContent As Variant
Dim strMyRange As String
Dim TestArray() As String
Dim target As String
Dim pos As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMyRange = ActiveCell.Address
varContent = ActiveCell.Value
For Each varData In Selection.Cells
If varData.Value <> varContent Then
strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address
TestArray = Split(strMyRange, ",")
target = TestArray(0)
pos = InStr(target, ":")
If (pos > 0) Then
Range(target).Merge
strMyRange = TestArray(1)
End If
varContent = Cells(varData.Row, varData.Column).Value
End If
Next
strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address))
Application.Wait (Now + #12:00:01 AM#) 'This helps the application run OK if there are no breakpoints.
Range(strMyRange).Merge
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub