Private Sub SelMergeCells()   ' выделить все сгруппированные ячейки в выделенном диапазоне
   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
   For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)
      If rCell.MergeCells Then
         If rMerge Is Nothing Then
            Set rMerge = rCell
         Else
            Set rMerge = Union(rMerge, rCell)
         End If
      End If
   Next rCell
   On Error Resume Next
   rMerge.Select
   If Err Then MsgBox "Объединённых ячеек в выделенном диапазоне не найдено"
End Sub

Private Sub FindMergeCells()   ' перебрать все объединённые ячейки в выделенном диапазоне и предложить пользователю их разгруппировать
   If Not TypeOf Selection Is Range Then Exit Sub
   If Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then Exit Sub
   Dim rCell As Range, i&, Arr()
   With CreateObject("Scripting.Dictionary")
      For Each rCell In Intersect(Selection, ActiveSheet.UsedRange)   ' собираем уникальные адреса объединённых ячеек в словарь
         If rCell.MergeCells Then .Item(rCell.MergeArea.Address(0, 0)) = 0&
      Next rCell
      If .Count = 0 Then MsgBox "Объединённых ячеек в выделенном диапазоне не найдено": Exit Sub
      Arr = .Keys   ' из массива .Keys читать поэлементно нельзя
      For i = 0 To .Count - 1
         ActiveSheet.Range(Arr(i)).Select
         If MsgBox("Разгруппировать ячейку [" & Arr(i) & "] ?", vbYesNo + vbQuestion, "Найдена объединённая ячейка") = vbYes Then Selection.UnMerge
      Next i
   End With
End Sub