Sub Merge_Similar_in_Columns()   ' группировать ячейки с одинаковыми значениями, идущие в столбцах подряд
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count <= 1 Then Exit Sub
    Dim rColumn As Range, rCell As Range, sAddress$, rMerge As Range, rTarget As Range
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Set rTarget = Intersect(Selection, ActiveSheet.UsedRange)
    For Each rCell In rTarget      ' разгруппировать с заполнением значениями (на всякий случай)
       If rCell.MergeCells Then
          sAddress = rCell.MergeArea.Address: rCell.UnMerge   ' разгруппировать
          Range(sAddress).Value = rCell.Value   ' заполнить
       End If
    Next
    rTarget.Select
    'Stop
    For Each rColumn In rTarget.Columns
       For Each rCell In rColumn.Cells   ' группировать ячейки с одинаковыми значениями
          If rMerge Is Nothing Then
             Set rMerge = rCell
          Else
             If rMerge(1).Value = rCell.Value Then
                Set rMerge = Union(rMerge, rCell): rMerge.Merge
             Else
                Set rMerge = rCell
             End If
          End If
       Next
       Set rMerge = Nothing
    Next
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

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

Sub UnMerge_and_Fill()
'---------------------------------------------------------------------------------------
' Procedure    : UnMerge_and_Fill
' Topic_HEADER : Снятие объединения ячеек с заполнением
' Topic_URL    : http://www.planetaexcel.ru/forum.phpстолбца?thread_id=3760
' Purpose      : Снимает объединение со всех ячеек выделенного диапазона
'                и заполняет все разгруппированные ячейки КАЖДОЙ бывшей группы
'                либо ссылками на значения верхней левой, либо её значениями
'---------------------------------------------------------------------------------------
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count <= 1 Then Exit Sub
    Dim rRange As Range, rCell As Range, sValue$, sAddress$, i&
    Application.ScreenUpdating = False
    Set rRange = Intersect(Selection, ActiveSheet.UsedRange)
    Select Case MsgBox("""ДА"" - заполнить ячейки формулами-ссылками на первую ячейку" & vbCrLf & _
                       """НЕТ"" - заполнить ячейки значениями из первой ячейки" & vbCrLf & _
                       """ОТМЕНА"" не разгруппировывать" _
                       , vbYesNoCancel + vbQuestion, "Как заполнять ячейки после разгруппировки?")
       Case vbYes   ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить формулами-ссылками на их первые ячейки
          For Each rCell In rRange
             If rCell.MergeCells Then
                sAddress = rCell.MergeArea.Address: rCell.UnMerge
                For i = 2 To Range(sAddress).Cells.Count
                   With Range(sAddress)
                      .Cells(i).Formula = "=" & .Cells(1).Address(False, False)
                      .Cells(i).Font.ColorIndex = 5   ' сделать шрифт формул синим (это на любителя, конечно)
                   End With
                Next i
             End If
          Next rCell
       Case vbNo    ' разгруппировать все ячейки в Selection и ячейки каждой бывшей группы заполнить значениями из их первых ячеек
          For Each rCell In rRange
             If rCell.MergeCells Then
                sAddress = rCell.MergeArea.Address: rCell.UnMerge
                Range(sAddress).Value = rCell.Value
             End If
          Next
       Case vbCancel
          'If MsgBox("Разгруппировать стандартным способом?", vbYesNo + vbQuestion) = vbYes Then Selection.UnMerge
    End Select
    rRange.Select
    Application.ScreenUpdating = True
End Sub