Sub ReMergeCells()
   If TypeName(Selection) <> "Range" Then Exit Sub
   If Selection.Cells.Count <= 1 Then Exit Sub
   If Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then Exit Sub
   Dim rMerge As Range, rCell As Range, sAddress$
   With Application: .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlManual: End With
   For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
      If rCell.MergeCells Then
         sAddress = rCell.MergeArea.Address: rCell.UnMerge
         Range(sAddress).Merge
      End If
   Next rCell
   With Application: .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlAutomatic: End With
End Sub