Sub MergeToOneCell()
   Const sDELIM As String = " " 'символ-разделитель
   Dim rCell As Range
   Dim sMergeStr As String
   If TypeName(Selection) <> "Range" Then Exit Sub 'если выделены не ячейки - выходим
   With Selection
       For Each rCell In .Cells
           sMergeStr = sMergeStr & sDELIM & rCell.Text  'собираем текст из ячеек
       Next rCell
       Application.DisplayAlerts = False   'отключаем стандартное предупреждение о потере текста
       .Merge Across:=False                'объединяем ячейки
       '.Merge Across:=True                ' или НЕ объединяем
       Application.DisplayAlerts = True
       .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM))    'добавляем суммарный текст
   End With
End Sub