Sub Test()
Dim irow As Range, icel As Range, MergeVal As String
 Application.DisplayAlerts = False
   For Each irow In Selection.Rows
     For Each icel In irow.Cells
       If icel.Value <> "" Then MergeVal = MergeVal & icel.Value & " "
     Next icel
   If MergeVal <> "" Then irow( 1 ).Value = Left(MergeVal, Len(MergeVal) -  1 )
   MergeVal = ""
   irow.Merge
   Next irow
 Application.DisplayAlerts = True
End Sub

Sub Test2()
Dim firstRow As Long, lastRow As Long, lastCol As String, SearchChar As String
Dim irow As Range, icel As Range, MergeVal As String
'номер первой строки
firstRow =  45 
' номер последней строки
lastRow = ActiveSheet.Range(firstCol & firstRow & ":" & firstCol & Rows.Count) _
   .Find("*", , , , xlByRows, xlPrevious).Row
'буква последнего столбца
firstCol = "B"
lastCol = "G"
SearchChar = "'Лист'"

 Application.DisplayAlerts = False
   For Each irow In Range(firstCol & firstRow & ":" & lastCol & lastRow).Rows
    If InStr(irow.Cells( 1 ).Value, SearchChar) =  1  Then
     For Each icel In irow.Cells
       If icel.Value <> "" Then MergeVal = MergeVal & icel.Value & " "
     Next icel
     irow.Cells( 1 ).Value = Left(MergeVal, Len(MergeVal) -  1 )
     MergeVal = ""
     irow.Merge
    End If
   Next irow
 Application.DisplayAlerts = True
End Sub

Sub UnTest()
Dim irow As Range, icel As Range, MergeVal As String, x As Variant, y
 Application.DisplayAlerts = False
   For Each irow In Selection.Rows
     With irow
       If .MergeCells Then
          .UnMerge
         ' разделитель " "(пробел)
         x = Split(.Cells( 1 ).Value, " ")
         For y =  0  To UBound(x)
          .Cells( 1 ).Offset( 0 , y).Value = x(y)
         Next
       End If
     End With
   Next irow
 Application.DisplayAlerts = True
End Sub

Sub Macro1()
    With Selection
        .UnMerge
        .Columns( 1 ).TextToColumns .Cells( 1 ), xlDelimited, , True, , , , True
    End With
End Sub

Sub UnTest()
Dim icel As Range, x As Variant
  Selection.UnMerge
  For Each icel In Selection.Columns( 1 ).Rows
    x = Split(icel.Value, " ")
    If UBound(x) >=  0  Then icel.Resize(,  1  + UBound(x)) = x
  Next
End Sub

Sub UnTest()
Dim icel As Range, x As Variant
  Selection.UnMerge
  For Each icel In Selection.Columns( 1 ).Rows
    x = Split(icel.Value, " ")
    If UBound(x) >=  0  Then icel.Resize(,  1  + UBound(x)) = x
  Next
End Sub

Sub UnTest2()
Dim icel As Range, x As Variant
 
With Selection
  .UnMerge
  Set icel = .Columns( 1 ).Find("*", , , , xlByRows, xlPrevious)
   If Not icel Is Nothing Then
     firstAddress = icel.Address
     Do
       x = Split(icel.Value, " ")
       icel.Resize(,  1  + UBound(x)) = x
       Set icel = .Columns( 1 ).FindNext(icel)
     Loop While Not icel Is Nothing And icel.Address <> firstAddress
   End If
End With

End Sub