Sub UnMerge_and_Fill()
     '---------------------------------------------------------------------------------------
     ' Procedure    : UnMerge_and_Fill
     ' Author       : The_Prist & Alex_ST
     ' 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
                       .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