VBA Merge Similar Cells - excel

Question

I would like to merge similar cells by columns, as of now I am using this macro
Sub MergeSimilarCells()
Set myRange = Range("A1:Z300")
CheckAgain:
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
Range(cell, cell.Offset(0, 1)).Merge
cell.VerticalAlignment = xlCenter
cell.HorizontalAlignment = xlCenter
GoTo CheckAgain
End If
Next
End Sub
My problem is with hundreds of rows and 40-50 columns, it takes forever.
I am pretty sure a For Loop could help me there but I am not skilled enough to figure it out
I know the following code is wrong but I am lost
Sub SimilarCells()
Set myRange = Range("A1:G4")
Dim count As Integer
CheckAgain:
count = 1
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
count = count + 1
ElseIf cell.Value <> cell.Offset(0, 1).Value Then
Range(cell, cell.Offset(0, -count)).Merge
End If
Next
End Sub
Here is what I would like to accomplish

Answer 1

Sub MergeMe()
Dim wks As Worksheet: Set wks = Worksheets(1)
Dim myRange As Range: Set myRange = wks.Range("B2:H5")
Dim myCell As Range
Dim myCell2 As Range
Dim firstColumn As Long: firstColumn = myRange.Columns(1).column + 1
Dim lastColumn As Long: lastColumn = firstColumn + myRange.Columns.Count - 1
Dim firstRow As Long: firstRow = myRange.Rows(1).row
Dim lastRow As Long: lastRow = firstRow + myRange.Rows.Count - 1
Dim column As Long
Dim row As Long
OnStart
For column = lastColumn To firstColumn Step -1
For row = lastRow To firstRow Step -1
Set myCell = wks.Cells(row, column)
Set myCell2 = myCell.Offset(0, -1)
If myCell.Value = myCell2.Value Then
With wks.Range(myCell, myCell2)
.Merge
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
End If
Next row
Next column
OnEnd
End Sub
There are quite a few tricks in this code:
we need to get the first and last column and row;
then we should be looping from the last cell (bottom right) to the first one (top left);
we should not enter the first column, because we are using .Offset(0,-1) and we compare every cell with its leftmost one;
the reason for the whole operation, is that by default, the value of a merged cells is kept in its left top cell. The other cells of a merged cell are without a value.
This is why we always compare the merged cells with their "left" neighbour;
These are the OnEnd and OnStart, facilitating the operation.
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
End Sub

Answer 2

Only one merge per group
EDITED to fix - thanks Vityata for the heads-up
Sub MergeEm()
Dim rw As Range, i As Long, s As Long, v
Range("C21:J33").Copy Range("C5:J17") 'for testing purposes: replace previous run
Application.ScreenUpdating = False
For Each rw In Range("C5:J17").Rows 'or wherever
i = 1
s = 1
Do While i < (rw.Cells.Count)
v = rw.Cells(i).Value
'check for a run of same values
Do While Len(v) > 0 And v = rw.Cells(i + s).Value
s = s + 1
If i + s > rw.Cells.Count Then Exit Do
Loop
'if s>1 then had a run: merge those ells
If s > 1 Then
Application.DisplayAlerts = False
rw.Cells(i).Resize(1, s).Merge
rw.Cells(i).HorizontalAlignment = xlCenter
Application.DisplayAlerts = True
i = i + s 'skip over the merged range
s = 1 'reset s
Else
i = i + 1
End If
Loop
Next rw
End Sub

Answer 3

I'm pretty sure what bloats your processing time is the goto causing you to loop through everything yet again every time after every merge
Edit to take column A into account and prevent first column cells to merge with cells outside of myRange:
Sub MergeSimilarCells()
Dim i As Long
Dim myCol As String
Set myRange = Range("K1:L30")
myCol = Left(myRange.Address(True, False), InStr(myRange.Offset(0, 1).Address(True, False), "$") - 1)
If Not Intersect(myRange, Range(myCol & ":" & myCol)).Address = myRange.Address Then
Set myRange = Range(Replace(myRange.Address, Left(myRange.Address(True, False), _
InStr(myRange.Address(True, False), "$")), Left(myRange.Offset(0, 1).Address(True, False), _
InStr(myRange.Offset(0, 1).Address(True, False), "$"))))
For i = myRange.Cells.Count To 1 Step -1
If myRange.Item(i).Value = myRange.Item(i).Offset(0, -1).Value And Not IsEmpty(myRange.Item(i)) Then
Range(myRange.Item(i), myRange.Item(i).Offset(0, -1)).Merge
myRange.Item(i).VerticalAlignment = xlCenter
myRange.Item(i).HorizontalAlignment = xlCenter
End If
Next
End If
End Sub
To clarify why myRange has to start in column B: Offset(0, -1) of any cell in column A will cause an error since there is no column to the left of A.