For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
          If rCell.MergeCells and Intersect(rCell, LastMergeArea) is nothing Then
              set LastMergeArea = rCell.MergeArea
              rCell.Select
              If MsgBox("Разгруппировать ячейку?", vbYesNo) = vbYes Then rCell.UnMerge
          End If
      Next rCell

Sub FindMergeCells()   ' перебрать все сгруппированные ячейки в выделенном диапазоне и предложить пользователю их разгруппировать
        If TypeName(Selection) <> "Range" Then Exit Sub
        If Selection.Cells.Count <= 1 Then Exit Sub
        Dim rCell As Range, rMergeArea As Range
        Set rMergeArea = Intersect(Selection, ActiveSheet.UsedRange)(1)
        For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
           If rCell.MergeCells And Intersect(rCell, rMergeArea) Is Nothing Then
              Set rMergeArea = rCell.MergeArea
              rCell.Select
              If MsgBox("Разгруппировать ячейку?", vbYesNo) = vbYes Then rCell.UnMerge
           End If
        Next rCell
End Sub

       Set rMergeArea = [A1]

If TypeName(Selection) <> "Range" Then Exit Sub

If not TypeOf Selection Is Range Then Exit Sub

If TypeName(Selection) <> "Range" Then Exit Sub

Public Sub UnMergeCells()
     Dim c As Range, s$, fA$
     Application.FindFormat.MergeCells = True
     With ActiveSheet.UsedRange
         Set c = .Find("", [a1], xlFormulas, 2, SearchFormat:=True)
         If Not c Is Nothing Then
             fA = c.Address: Do
                 If UBound(c.MergeArea.Formula) = 1 Then
                     s = c.MergeArea.Address: c.UnMerge
                     Range(s).HorizontalAlignment = 7
                 End If
                 Set c = .Find("", c, xlFormulas, 2, SearchFormat:=True)
             Loop While Not c Is Nothing And c.Address <> fA
         End If
     End With
End Sub

Application.FindFormat.MergeCells

Sub UnMergeInRangeSelection()
     Dim MAreas As New Collection
     Dim SRng As Range, Cell As Range
     '
     On Error Resume Next
     Set SRng = Selection
     If SRng Is Nothing Then
         Err.Clear
         Exit Sub
     End If
     Set SRng = Intersect(SRng, ActiveSheet.UsedRange)
     For Each Cell In SRng
         If Cell.MergeCells Then MAreas.Add Cell.MergeArea, Cell.MergeArea.Address
     Next
     On Error GoTo 0
     If MAreas.Count > 0 Then
         For Each Cell In MAreas
             Cell.Select
             If MsgBox(Cell.Address, vbYesNo + vbDefaultButton2, "Разъединить ?") = vbYes Then Cell.UnMerge
         Next
     Else
         MsgBox "В выбранном диапазоне нет объединенных ячеек.", , ""
     End If
End Sub

Sub UnMerge()
     Dim area As Range
     Dim cell As Range
      
     If Not TypeOf Selection Is Range Then Exit Sub
      
     For Each area In Intersect(Selection, ActiveSheet.UsedRange).areas
         For Each cell In area
             If cell.MergeCells And cell.Address = cell.MergeArea.Cells(1).Address Then
                 If MsgBox(cell.Address, vbYesNo + vbDefaultButton2, "Unmerge?") = vbYes Then
                     cell.UnMerge
                 End If
             End If
         Next
     Next
End Sub

Sub FindMergeCells()   ' перебрать все объединённые ячейки в выделенном диапазоне и предложить пользователю их разгруппировать
    If Not TypeOf Selection Is Range Then Exit Sub
    If Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then Exit Sub
    Dim rArea As Range, rCell As Range
    Dim rSel As Range: Set rSel = Selection   'только для того, чтобы можно было восстановить Selection после обработки
    For Each rArea In Intersect(Selection, ActiveSheet.UsedRange).Areas
       For Each rCell In rArea
          If rCell.MergeCells And rCell.Address = rCell.MergeArea.Cells(1).Address Then
             rCell.Select
             If MsgBox("Разгруппировать ячейку " & rCell.Address(0, 0) & " ?", vbYesNo + vbQuestion, "Найдена объединённая ячейка") = vbYes Then rCell.UnMerge
          End If
       Next rCell
    Next rArea
    rSel.Select   ' восстановить Selection после обработки
End Sub

Sub io()
      Dim Range As Range
      Range("A1").Select       ' err: локальное имя перекрыло глобальное
End Sub

cell.Address = cell.MergeArea.Cells(1).Address

rCell.Address = rCell.MergeArea.Cells(1).Address

rCell.Address = rCell.Cells(1).Address