Join cells based on value of a cell vba

Question

I am trying to join cells in a row if a value exists in a cell in that row.

The data has been imported from a .txt file and various sub headers are split along 2, 3 or 4

Answer 1

Ok, so I've created an answer, but it ain't pretty (kinda like the whole project I've created).

It works although I'm sure there is a much simpler way of creating it.

Maybe someone can have a go at cleaning it up?

Sub SelRows()

Dim ocell As Range
Dim rng As Range
Dim r2 As Range

For Each ocell In Range("B1:B1000")

    If ocell.Value Like "*contain*" Then

        Set r2 = Intersect(ocell.EntireRow, Columns("A:G"))

        If rng Is Nothing Then

            Set rng = Intersect(ocell.EntireRow, Columns("A:G"))
        Else

            Set rng = Union(rng, r2)
        End If
    End If
Next

Call JoinAndMerge


If Not rng Is Nothing Then rng.Select

Set rng = Nothing
Set ocell = Nothing
End Sub

Private Sub JoinAndMerge()
Dim outputText As String, Rw As Range, cell As Range
delim = " "
Application.ScreenUpdating = False
For Each Rw In Selection.Rows
For Each cell In Rw.Cells
    outputText = outputText & cell.Value & delim
Next cell
With Rw
.Clear
.Cells(1).Value = outputText
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
outputText = ""
Next Rw
Application.ScreenUpdating = True
End Sub

Answer 2

Not sure if this is exactly what you want but it will get you close:

Sub summary()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim N As Long, i As Long, r1 As Range, r2 As Range
    Dim z As Long
    Dim arr() As Variant
    z = 1
    Set sh1 = ActiveSheet
    With ActiveWorkbook
        Set sh2 = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
    End With

    With sh1
        N = .Cells(Rows.Count, "A").End(xlUp).Row
        For i = 1 To N
            If .Cells(i, "A").Value Like "Summary*" Then
                arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
                sh2.Cells(z, "A").Value = Join(arr, " ")
                z = z + 1
            End If
        Next i
    End With
End Sub