Merge Cells of one specific column if equal value - excel

Question

I need to loop over all rows (except my header rows) and merge all cells with the same value in the same column. Before I do this I already made sure, that the column is sorted.
So I have some setup like this.
a b c d e
1 x x x x
2 x x x x
2 x x x x
2 x x x x
3 x x x x
3 x x x x
And need this
a b c d e
1 x x x x
2 x x x x
x x x x
x x x x
3 x x x x
x x x x
With my code I achieved to merge two equal cells. Instead I need to merge all equal cells.
Dim i As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 1) <> "" Then
If Cells(i, 1) = Cells(i - 1, 1) Then
Range(Cells(i, 1), Cells(i - 1, 1)).Merge
End If
End If
Next i

Answer 1

This method does not use merged cells, but achieves the same visual effect:
Say we start with:
Running this macro:
Sub HideDups()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 3 Step -1
With Cells(i, 1)
If .Value = Cells(i - 1, 1).Value Then
.Font.ColorIndex = 2
End If
End With
Next i
End Sub
will produce this result:
NOTE:
No cells are merged. This visual effect is the same because consecutive duplicates in the same column are "hidden" by having the colour of the font be the same as the colour of the cell background.

Answer 2

I know this is an old thread, but I needed something similar. Here's what I came up with.
Sub MergeLikeCells()
Dim varTestVal As Variant
Dim intRowCount As Integer
Dim intAdjustment As Integer
ActiveSheet.Range("A1").Select
'Find like values in column A - Merge and Center Cells
While Selection.Offset(1, 0).Value <> ""
'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
intRowCount = 1
varTestVal = Selection.Value
While Selection.Offset(1, 0).Value = varTestVal
intRowCount = intRowCount + 1
Selection.Offset(1, 0).Select
Selection.ClearContents
Wend
intAdjustment = (intRowCount * -1) + 1
Selection.Offset(intAdjustment, 0).Select
Selection.Resize(intRowCount, 1).Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Offset(1, 0).Resize(1, 1).Select
Wend
End Sub

Answer 3

My solution as below, have a good day!
Sub MergeSameValue()
Application.DisplayAlerts = False
Dim LastRow As Integer
Dim StartRow As Integer
StartRow = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim StartMerge As Integer
StartMerge = StartRow
For i = StartRow + 1 To LastRow
If Cells(i, 1) <> "" Then
If Cells(i, 1) <> Cells(i - 1, 1) Then
Range(Cells(i - 1, 1), Cells(StartMerge, 1)).Merge
StartMerge = i
End If
End If
Next i
End Sub