VBA macro for combining several cells into one

[geomano]

Hi, I have a VBA macro for combining values from some columns into one. Now, what I would like to add is an option to combine those values into one cell with some spacing between lines, provided they have the same number in column A.

So that's my raw data:
1111111.jpg
Now, I run my macro to combine the columns:
22222222.jpg
And that's the final outcome, I would like to achieve:
4444444444.jpg
I am attaching my spreadsheet for your reference.

Thank you for your help.

[mana]

Option Explicit

Sub test()
    Dim r As Range
    Dim s  As String


    For Each r In Cells(1).CurrentRegion.Columns("G:I").Rows
        s = s & vbLf & Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(r)))
    Next
  
    MsgBox Mid(s, 2)
    
End Sub

[mdmackillop]

If your data has a header row, you should show it in your example.

This assume an ordered list of differing numbers in Column A.
Using Mana's Join code but the loop seems clumsy here. Surely a better way.

Sub test()
    Dim dic, d
    Dim r As Range
    Dim i As Long
    Dim s As String


    Rows(1).Insert
    Cells(1, 1) = "TempHeader"
    Set dic = CreateObject("Scripting.Dictionary")
    Set r = Sheet1.Cells(1, 1).CurrentRegion.Columns(1).Cells
    
    On Error Resume Next
    For i = 2 To r.Cells.Count - 1
        dic.Add CStr(r(i)), CStr(r(i))
    Next
    On Error GoTo 0
    
    For Each d In dic
        Columns(1).AutoFilter 1, d
        For Each r In Cells(1).CurrentRegion.Columns("G:I").Rows
            If r.Hidden = False Then
                s = s & vbLf & Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(r)))
            End If
        Next
        Columns(1).Find(d).Offset(, 10) = s
        s = ""
    Next d
    Columns(1).AutoFilter
    Rows(1).Delete
End Sub

[geomano]

Thank you so much, that's precisely what I tried to create!

[mike7952]

Another way with out a loop. I Posted solution here https://www.excelforum.com/excel-pro...ml#post4623106

Sub Concat()
 Dim txt As String
 With Sheets(2)
    With .Range("i1", .Cells(Rows.Count, "i").End(xlUp))
        .Offset(, 1).Value = "=RC[-3] & "" "" & RC[-2] & "" "" & RC[-1]"
        .Offset(, 1).Value = .Offset(, 1).Value
        txt = Join(Application.Transpose(.Offset(, 1).Value), vbNewLine)
    End With
    .[k1] = txt
 End With
End Sub