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 columns.

The cells cant be merged as the data will only be kept from the first cell.

The only words which are always constant are "contain" and "for" in column B.

What I've tried resembles this:

If cell.Value like "contain", or "for" then join all cells from column "A" to column "H" into column "B", align them centrally and make them bold.

thanks, in advance, for any help.

Edit Here is the code:

    Sub Joining()
    Dim N As Long, i As Long, r1 As Range, r2 As Range
 Dim z As Long
 Dim arr() As Variant
 z = 1

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

End Sub

Much better. So what part of my first comment did you not understand?? — findwindow, May 13 '16 at 21:28
[TEXTJOIN for xl2010/xl2013 with criteria](https://stackoverflow.com/questions/50716550/textjoin-for-xl2010-xl2013-with-criteria/50719050#50719050) — , Jul 16 '18 at 23:46

score 1 · Answer 1 · answered May 13 '16 at 21:34

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

Sorry I Copied the wrong code, kinda felt pressured into sharing it even though i knew it wasn't correct. I only need the sub to work in the Active sheet. I altered what you sent but it didn't work. ill post below — James Hurst, May 13 '16 at 21:45

score 0 · Accepted Answer · answered May 15 '16 at 00:02

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

Join cells based on value of a cell vba

2 Answers2

Linked