Find columns with specific string in Row 1 then join their cells in another column

[spidaman]

Can anyone help out with this please?

I need to Find all columns that have a specific string in the header in Row 1 (this is a variable number of columns), then for each row from all those columns, if the cell is not empty, merge the contents into a single string for each corresponding row in another column.
The range that is to be populated with the concatenated string is ToFin here:

Dim titRng As Range, foundCell22 As Range, ToFin As Range

TargetStr22 = "Other String"


Set foundCell22 = titRng.Find(what:=TargetStr22, LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=True, SearchFormat:=False)


foundCell22.EntireColumn.Insert
Set ToFin = Intersect(foundCell22.Offset(0, -1).EntireColumn, ws1.UsedRange)


For Each FinAtCel In ToFin


[COLOR=#008000]'  join values from each column where the Value in Row 1 is "Attribs Replaced" with a " / " between each joined cell[/COLOR]


Next FinAtCel

Any help much appreciated!

 

[DanteAmor]

Try this

Sub conca()
    Dim r As Range, Str22 As String, cell As String
    Dim cols As New Collection, lastrow As Long, lastcol As Long
    
    Set r = Rows(1)
    Str22 = "Other"
    
    Set f = r.Find(Str22, LookIn:=xlValues, lookat:=xlWhole)
    If Not f Is Nothing Then
        cell = f.Address
        Do
            cols.Add f.Column
            Set f = r.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
    End If
    
    lastrow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    lastcol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column + 1
    For i = 2 To lastrow
        cad = ""
        For j = 1 To cols.Count
            If Cells(i, cols(j)).Value <> "" Then
                cad = cad & Cells(i, cols(j)).Value & " / "
            End If
        Next
        If cad <> "" Then Cells(i, lastcol).Value = Left(cad, Len(cad) - 3)
    Next
End Sub

 

[spidaman]

DanteAmor gracias por tu ayuda con este.

I think I did not explain what I want to do very well.

Regarding this part of your code:

    Set f = r.Find(Str22, LookIn:=xlValues, lookat:=xlWhole)
    If Not f Is Nothing Then
        cell = f.Address
        Do
            cols.Add f.Column
            Set f = r.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
    End If

There will only be 1 occurrence of Str22 in the ActiveWorkbook. So this string just needs to be found and then a blank column inserted before it. For each cell in this new column I then need to concatenate the corresponding cells from any column that has the string "Attribs Replaced" in the header row(1) if they are not empty. Finally I'd like to add " / " between the contents of each cell being joined.

Does that make more sense?

 

[DanteAmor]

Now I do not understand.
You could explain it with example, using data and cells. Just imagine a real case and explain it using data.

 

[spidaman]

1. First I'd like to find the cell in row 1 that contains the string "Original". There will only be one cell with this value. Then select the entire column and insert a blank column in front.

This is how I was doing it and this code works ok:

Dim titRng As Range
Dim TargetStr As String

TargetStr = "Original"
Set titRng = ActiveWorkbook.Sheets(1).Rows(1)


Set foundCell = titRng.Find(what:=TargetStr, LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=True, SearchFormat:=False)


foundCell.EntireColumn.Insert

2. Then I'd like to find every column with a different string "Attribs" in the header. Then join each of these columns in the new blank column create above.
So if for example the new blank column created above is at C:C and the string "Attribs" is found in cells M1, X1, AB1 and AD1, then in column C:C I want to join the values from columns M:M, X:X, AB:AB and AD:AD.

Is that any better?

 

[DanteAmor]

Try this

Sub conca()
    Dim sh As Worksheet, r As Range, Str1 As String, Str2 As String, cell As String
    Dim cols As New Collection, lr As Long, NewCol As Long
    
    Set sh = ActiveWorkbook.Sheets(1)
    Set r = sh.Rows(1)
    Str1 = "Original"
    Str2 = "Attribs"
    
    'search string1
    Set f = r.Find(Str1, LookIn:=xlValues, lookat:=xlWhole)
    If Not f Is Nothing Then
        lr = sh.Cells(Rows.Count, f.Column).End(xlUp).Row
        NewCol = f.Column
        f.EntireColumn.Insert
    Else
        'dont exists str1
        Exit Sub
    End If
    
    'search string2
    Set f = r.Find(Str2, LookIn:=xlValues, lookat:=xlPart)
    If Not f Is Nothing Then
        cell = f.Address
        Do
            cols.Add f.Column
            Set f = r.FindNext(f)
        Loop While Not f Is Nothing And f.Address <> cell
    Else
        'dont exists str1
        Exit Sub
    End If
    
    For i = 2 To lr
        cad = ""
        For j = 1 To cols.Count
            If Cells(i, cols(j)).Value <> "" Then
                cad = cad & Cells(i, cols(j)).Value & " / "
            End If
        Next
        If cad <> "" Then Cells(i, NewCol).Value = Left(cad, Len(cad) - 3)
    Next
End Sub

 

[spidaman]

DanteAmor thank you very much this code works. Your time is much appreciated.

I don't understand the final line:

If cad <> "" Then Cells(i, NewCol).Value = Left(cad, Len(cad) - 3)

Could you please explain what is happening here?

 

[DanteAmor]

DanteAmor thank you very much this code works. Your time is much appreciated.

I don't understand the final line:

If cad <> "" Then Cells(i, NewCol).Value = Left(cad, Len(cad) - 3)

Could you please explain what is happening here?

The macro concatenates a data string, if at the end the string contains something, then it puts the string in the cell, but the string always ends with something like this: "/" and with the instruction LEFT that part is deleted.

 

[spidaman]

The macro concatenates a data string, if at the end the string contains something, then it puts the string in the cell, but the string always ends with something like this: "/" and with the instruction LEFT that part is deleted.

Yes I understand now; thanks for explaining. Thanks again for your help and for introducing me to collections!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.