Sub ert()
Dim r As Range, adr$, s$
With CreateObject("Scripting.Dictionary")
     For Each r In Intersect(Selection, ActiveSheet.UsedRange)
         If r.MergeCells Then
             adr = r.MergeArea.Address
             If Not .Exists(adr) Then .Item(adr) = 1: s = s & "," & adr
         End If
     Next
End With: If s = vbNullString Then Exit Sub
For Each r In Range(Mid(s, 2)).Areas
     r.Select
     If MsgBox("Разгруппировать ячейку " & r.Address(0, 0) & " ?", 36, _
               "Найдена объединённая ячейка") = vbYes Then r.UnMerge
Next r
End Sub

Sub UnMerge()
     Dim area As Range
     Dim cell As Range
     Dim usedRange As Range
     Dim cellAddress As String
     Dim mergeCells As New Collection
      
     Set usedRange = Intersect(ActiveWindow.RangeSelection, ActiveSheet.usedRange)
     If usedRange Is Nothing Then Exit Sub
      
     For Each area In usedRange.Areas
         For Each cell In area
             If cell.mergeCells Then
                 cellAddress = cell.MergeArea.Cells(1).address
                 If Not InCollection(mergeCells, cellAddress) Then
                     If MsgBox(cell.address, vbYesNo + vbDefaultButton2, "Unmerge?") = vbYes Then
                         cell.UnMerge
                     Else
                         mergeCells.Add cellAddress, cellAddress
                     End If
                 End If
             End If
         Next
     Next
End Sub

Private Function InCollection(ByRef col As Collection, _
                    ByRef address As String) As Boolean
     On Error Resume Next
     InCollection = Not IsEmpty(col.Item(address))
End Function