Sub MergePlus()
     '---------------------------------------------------------------------------------------
     ' Procedure : MergePlus
     ' Author    : The_Prist & Alex_ST
     ' URL       : http://www.planetaexcel.ru/forum.php?thread_id=13533
     ' Theme     : Объединение ячеек без потери данных
     ' Date      : 17.02.2010
     ' Purpose   : Объединить ячейки в Selection без потери данных
     '---------------------------------------------------------------------------------------
     If TypeName(Selection) <> "Range" Then Exit Sub
     If Selection.Cells.Count <= 1 Then Exit Sub
     Dim wsTempSh As Worksheet, wsActSh As Worksheet
     Dim rRange As Range, rMrgRange As Range
     Dim i%
     Application.ScreenUpdating = False: Application.DisplayAlerts = False
     Select Case MsgBox("""ДА"" - заполнить ячейки формулами-ссылками на первую ячейку" & vbCrLf & _
                        """НЕТ"" - оставить имеющиеся в ячейках значения" & vbCrLf & _
                        """ОТМЕНА"" не объединять ячейки" _
                        , vbYesNoCancel + vbQuestion + vbDefaultButton1, "Заполнить ячейки перед объединением?")
        Case vbCancel: Exit Sub
        Case vbYes   ' перед объединением заполнить Selection формулами-ссылками на первую ячейку
           For i = 2 To Selection.Cells.Count
              Selection(i).Formula = "=" & Selection(1).Address
              Selection(i).Replace What:="$", Replacement:="", LookAt:=xlPart  ' сделать ссылки перемещаемыми
           Next
     End Select
     Set wsActSh = ActiveSheet: Set wsTempSh = Sheets.Add
     wsActSh.Activate
     Set rRange = Selection: rRange.Copy wsTempSh.Range(rRange.Address)   ' копировать rRange = Selection на новую страницу
     Set rMrgRange = wsTempSh.Range(rRange.Address)   ' на новой странице объединить ячейки в rRange
     rMrgRange.Merge: rMrgRange.Copy: rRange.PasteSpecial xlPasteFormats: wsTempSh.Delete
     Set wsActSh = Nothing: Set wsTempSh = Nothing: Set rMrgRange = Nothing: Set rRange = Nothing
     Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub