Объединение текста из нескольких ячеек в одну ячейке, по всей таблице

Sub Макрос1()
Dim delim As String, newdata As String
Dim rng As Range
If TypeName(Selection) <> "Range" Or Selection.Count <= 1 Then Exit Sub
delim = " "
newdata = ""
For Each rng In Selection
newdata = newdata & rng.Value & delim
Next rng
Application.DisplayAlerts = False
Selection.Merge
Selection = Left(newdata, Len(newdata) - Len(delim))
Application.DisplayAlerts = True
Selection.UnMerge
End Sub

Public Sub Test()
Dim r As Range, c As Range, p As Range, last As Range
    
    [A:A].UnMerge ' Снимает объединение, чтобы не мешало (можно убрать)
    
    ' Вычисляет последнюю непустую ячейку (если нужно 100 - меняйте на 100)
    Set last = Range("A" & Rows.Count).End(xlUp)
 
    Set r = Range("A1", last) ' просматриваемый диапазон
    For Each c In r
        If Not IsEmpty(c) Then
            If Not p Is Nothing Then
                ' Можно вычислить высоту объединяемой группы
                ' если нужна меньше чем
                Range(p, c.Offset(-1, 0)).Merge
            End If
            Set p = c
        End If
    Next c
    
    ' Последняя (объединяется до сотой)
    If 100 - p.Row > 1 Then p.Resize(100 - p.Row).Merge
End Sub

Sub Proba1()
Dim Last As Integer, I As Integer, J As Integer, S As String
Last = Cells(Rows.Count, 5).End(xlUp).Row
J = Last
For I = Last To 2 Step -1
  S = Cells(I, 5) & " " & S
  If Cells(I, 1) <> "" Then
    Cells(I, 5) = S: S = ""
    Rows(I + 1 & ":" & J).Delete: J = I - 1
    Rows(I & ":" & I).EntireRow.AutoFit
  End If
Next
End Sub

Sub AddData()
    Dim Str1 As String, Str2 As String, Str3 As String
    Dim LastRow As Long, i As Long
    
    Sheets("Лист1").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "data"
    
    With Worksheets("data")
        LastRow = .Cells(Rows.Count, 15).End(xlUp).Row
        For i = LastRow To 1 Step -1
            If .Cells(i, 1) = vbNullString Then
                If .Cells(i, 7) <> vbNullString Then Str1 = .Cells(i, 7) & " " & Str1
                If .Cells(i, 9) <> vbNullString Then Str2 = .Cells(i, 9) & " " & Str2
                If .Cells(i, 15) <> vbNullString Then Str3 = .Cells(i, 15) & " " & Str3
                .Rows(i & ":" & i).Delete
            Else
                .Cells(i, 7) = .Cells(i, 7) & Str1
                .Cells(i, 9) = .Cells(i, 9) & Str2
                .Cells(i, 15) = .Cells(i, 15) & Str3
                Str1 = vbNullString: Str2 = vbNullString: Str3 = vbNullString
            End If
        Next i
    End With
End Sub

Sub Объединение()
Dim i As Long
Dim fin As Long
    fin = 6919
        For i = 71 To fin Step 42
            Range("bg" & i) = "=R29C59:R29C69" = Application.DisplayAlerts = False
            Selection.Merge
                     
            
        Next i
End Sub