```
Public Sub mergeSameCell()
Dim rng As Excel.Range, rngPrev As Excel.Range
Dim rngAll As Excel.Range, rngMerge As Excel.Range
Dim rngBegin As Excel.Range, rngEnd As Excel.Range
If VBA.TypeName(Selection) <> "Range" Then Exit Sub
Set rngAll = Application.Selection
Application.Calculation = Excel.xlCalculationManual
Application.ScreenUpdating = False
For Each rng In rngAll.Cells
If rngBegin Is Nothing Then
Set rngBegin = rng
ElseIf rng.Value <> rngPrev.Value Or rng.Row <> rngPrev.Row Then
Set rngEnd = rngPrev
Set rngMerge = Range(rngBegin, rngEnd)
If rngMerge.Cells.Count > 1 Then
Application.DisplayAlerts = False
rngMerge.Merge
Application.DisplayAlerts = True
End If
Set rngBegin = rng
End If
Set rngPrev = rng
Next rng
Set rngEnd = rngAll.Cells(rngAll.Cells.Count)
Set rngMerge = Range(rngBegin, rngEnd)
If rngMerge.Cells.Count > 1 Then
Application.DisplayAlerts = False
rngMerge.Merge
Application.DisplayAlerts = True
End If
Application.Calculation = Excel.xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
```