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

Sub test2()
Dim RowIndex As Long
Dim StartRow As Long
Dim ColumnToMerge As Long
Dim countHPageBreak As Long
Dim hPB As HPageBreak
Dim pageLastRow() As Variant
Dim i As Long, ihPB As Long
    
    StartRow =  2  ' с какой строки начинать
    ColumnToMerge =  2  ' в какой колонке объединять

    countHPageBreak = ActiveSheet.HPageBreaks.Count
    
    ReDim pageLastRow(countHPageBreak) As Variant
    
    i =  0 
    For Each hPB In ActiveSheet.HPageBreaks
     pageLastRow(i) = hPB.Location.Row -  1 
     i = i +  1 
    Next hPB
    pageLastRow(countHPageBreak) = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row
    
    
    
    Application.DisplayAlerts = False

    For ihPB =  0  To countHPageBreak
        
        For RowIndex = StartRow +  1  To pageLastRow(ihPB)
            With Cells(RowIndex, ColumnToMerge)
                If .Value = .Offset(- 1 ,  0 ).MergeArea.Cells( 1 ).Value Then
                    Range(Cells(RowIndex, ColumnToMerge), .Offset(- 1 ,  0 )).Merge
                End If
            End With
        Next RowIndex
        
        StartRow = pageLastRow(ihPB) +  1 
    Next ihPB

    Application.DisplayAlerts = True
    
End Sub

Sub test()
' объединяет ячейки содинаковыми значениями на странице в указанном столбце
Dim RowIndex As Long
Dim StartRow As Long
Dim LastRow As Long
Dim ColumnToMerge As Long
Dim countHPageBreak As Long
Dim hPB As HPageBreak
Dim pageLastRow() As Variant
Dim i As Long, ihPB As Long
Dim flag As Boolean
    
    
    StartRow =  2  ' с какой строки начинать
    ColumnToMerge =  2  ' в какой колонке объединять
    flag = True  ' учитывать ли значения слева False - нет, True - да

    countHPageBreak = ActiveSheet.HPageBreaks.Count
    
    ReDim pageLastRow(countHPageBreak) As Variant
    
    i =  0 
    For Each hPB In ActiveSheet.HPageBreaks
     pageLastRow(i) = hPB.Location.Row -  1 
     i = i +  1 
    Next hPB
    pageLastRow(countHPageBreak) = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row
    
    
    
    Application.DisplayAlerts = False

    For ihPB =  0  To countHPageBreak
        
        For RowIndex = StartRow +  1  To pageLastRow(ihPB)
            
            With Cells(RowIndex, ColumnToMerge)
                
                If .Value = .Offset(- 1 ,  0 ).MergeArea.Cells( 1 ).Value Then
                  If flag Then
                     If .Offset( 0 , - 1 ).MergeArea( 1 ).Value = .Offset(- 1 , - 1 ).MergeArea( 1 ).Value Then  '.Offset(0, -1).MergeArea.Address <> .Offset(-1, -1).MergeArea.Address Then
                         Range(Cells(RowIndex, ColumnToMerge), .Offset(- 1 ,  0 )).Merge
                     End If
                   Else
                  Range(Cells(RowIndex, ColumnToMerge), .Offset(- 1 ,  0 )).Merge
                  End If
                End If
           
            End With
            
            
        Next RowIndex
        
        StartRow = pageLastRow(ihPB) +  1 
    Next ihPB

    Application.DisplayAlerts = True

End Sub

If .Offset( 0 , - 1 ).MergeArea( 1 ).Value = .Offset(- 1 , - 1 ).MergeArea( 1 ).Value Then

If .Offset( 0 , - 1 ).MergeArea.Address = .Offset(- 1 , - 1 ).MergeArea.Address Then

    i =  0 
    For Each hPB In ActiveSheet.HPageBreaks
     pageLastRow(i) = hPB.Location.Row -  1 
     i = i +  1 
    Next hPB
    pageLastRow(countHPageBreak) = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row

  ActiveWindow.View = xlPageBreakPreview
    i =  0 
    For Each hPB In ActiveSheet.HPageBreaks
     pageLastRow(i) = hPB.Location.Row -  1 
     i = i +  1 
    Next hPB
    pageLastRow(countHPageBreak) = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row
  ActiveWindow.View = xlNormalView

Dim StartRow As Long
Dim ColumnToMerge As Long
Dim flagCol As Boolean
Dim flagPag As Boolean


Sub test()
' объединяет ячейки содинаковыми значениями на странице в указанном столбце
Dim LastRow As Long
Dim countHPageBreak As Long
Dim hPB As HPageBreak
Dim pageLastRow() As Variant
Dim i As Long, ihPB As Long
    
    StartRow =  2  ' с какой строки начинать
    ColumnToMerge =  2  ' в какой колонке объединять
    flagCol = True   ' учитывать ли значения слева False - нет, True - да
    flagPag = False  ' учитывать ли разбиение страниц False - нет, True - да
    
 LastRow = Cells(Rows.Count, ColumnToMerge).End(xlUp).Row

    
Application.DisplayAlerts = False
If flagPag Then

    countHPageBreak = ActiveSheet.HPageBreaks.Count
    
    ReDim pageLastRow(countHPageBreak) As Variant
    
  ActiveWindow.View = xlPageBreakPreview
    i =  0 
    For Each hPB In ActiveSheet.HPageBreaks
     pageLastRow(i) = hPB.Location.Row -  1 
     i = i +  1 
    Next hPB
 ActiveWindow.View = xlNormalView
    pageLastRow(countHPageBreak) = LastRow
        
     For ihPB =  0  To countHPageBreak
       myMerg pageLastRow(ihPB)
       StartRow = pageLastRow(ihPB) +  1 
     Next ihPB
     
Else
   
      myMerg LastRow
    
End If
Application.DisplayAlerts = True

End Sub


Sub myMerg(ByVal lastToMerg As Long)
Dim RowIndex As Long
        
        For RowIndex = StartRow +  1  To lastToMerg
            
            With Cells(RowIndex, ColumnToMerge)
                
                If .Value = .Offset(- 1 ,  0 ).MergeArea.Cells( 1 ).Value Then
                  If flagCol Then
                     If .Offset( 0 , - 1 ).MergeArea( 1 ).Value = .Offset(- 1 , - 1 ).MergeArea( 1 ).Value Then  '.Offset(0, -1).MergeArea.Address <> .Offset(-1, -1).MergeArea.Address Then
                         Range(Cells(RowIndex, ColumnToMerge), .Offset(- 1 ,  0 )).Merge
                     End If
                   Else
                  Range(Cells(RowIndex, ColumnToMerge), .Offset(- 1 ,  0 )).Merge
                  End If
                End If
           
            End With
            
        Next RowIndex
End Sub

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 Макрос2()
    [A1:A4].NumberFormat = "@"
    [A1:A4] = [A1:A4 & "."]
End Sub