Sub UnMerge_and_Fill()
'---------------------------------------------------------------------------------------
' Procedure : UnMerge_and_Fill
' Topic_HEADER : Снятие объединения ячеек с заполнением
' Topic_URL : http://www.planetaexcel.ru/forum.php?thread_id=3760
' Author: Дмитрий "The_Prist" Щербаков (http://www.excel-vba.ru/)
' Editor: Alex ST
' Purpose : Снимает объединение со всех ячеек выделенного диапазона
' и заполняет все разгруппированные ячейки КАЖДОЙ бывшей группы
' либо ссылками на значения верхней левой, либо её значениями
'---------------------------------------------------------------------------------------
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
.Cells(i).Replace What:="$", Replacement:="", LookAt:=xlPart ' сделать ссылки перемещаемыми
.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: sValue = rCell.Value: 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

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
    Application.Calculation = xlCalculationManual
    
    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.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub