How to concatenate severals columns using VBA - excel

Question

Let's say I have this table :
I would want to see :
A follow up from this question:
I can't for the life of me understand this code in order to add more columns. The code work for 'Name, Type, Food' but I need to add 'Place' and 'date'.
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Feuil1
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array
arr = .Range("A2:C" & lr).Value
'Loop through array
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
dict(arr(x, 1) & "|" & arr(x, 2)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2)), arr(x, 3)), ", ")
Else
dict(arr(x, 1) & "|" & arr(x, 2)) = arr(x, 3)
End If
Next x
'Loop through dictionary
For x = 0 To dict.Count - 1
.Cells(x + 2, 8).Resize(, 2).Value = Split(dict.keys()(x), "|")
.Cells(x + 2, 10).Value = dict.items()(x)
Next x
End With
End Sub

Answer 1

Some relative "simple" adjustments would make this work:
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array
arr = .Range("A2:E" & lr).Value
'Loop through array
For x = LBound(arr) To UBound(arr)
If dict.Exists(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) Then
dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)), arr(x, 3)), ", ")
Else
dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = arr(x, 3)
End If
Next x
'Loop through dictionary
For x = 0 To dict.Count - 1
.Cells(x + 2, 6).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(0), "|")
.Cells(x + 2, 8).Value = dict.items()(x)
.Cells(x + 2, 9).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(1), "|")
Next x
End With
End Sub
Hopefully you'll be able to understand. And all good about the unfortunate wording in your original question. No worries.
Happy coding

Answer 2

Here's a generic function which will return a summarized version of a data table, according the the specified "key" and "value" columns.
(only posted here as your follow-up question is still closed: please do not mark this as an answer here)
Sub Tester()
Dim arr
'summarize the input table
arr = Summarize(ActiveSheet.Range("B2").CurrentRegion, Array(1, 2, 4), Array(3, 5))
'put the output on the sheet
ActiveSheet.Range("h2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
'Given an input table rngData (incl. headers), summarize according to
' the "key" columns in arrKeyCols, concatenating values in arrValueCols
' Note: supply column numbers relative to the input range, not the worksheet
' If your table starts in ColB, then the first column is 1, not 2
Function Summarize(rngData As Range, arrKeyCols, arrValueCols)
Dim arr As Variant, arrOut, v
Dim dict As Object, k, r As Long, r2, c As Long, rOut As Long
Set dict = CreateObject("Scripting.Dictionary")
arr = rngData.Value '<< input data, including headers
'Size the output array and copy the headers
' Might have empty "rows" at the end but that's not worth fixing
' given the possible case where no input rows share the same "key"
ReDim arrOut(1 To UBound(arr, 1), 1 To UBound(arr, 2))
For c = 1 To UBound(arr, 2)
arrOut(1, c) = arr(1, c)
Next c
rOut = 2 'start populating output array on this "row"
'loop over the input data
For r = 2 To UBound(arr, 1)
'build the "key" for this row from the key columns passed in arrKeyCols
k = ""
For c = 0 To UBound(arrKeyCols)
k = k & IIf(c > 0, Chr(0), "") & arr(r, arrKeyCols(c))
Next c
'Find the matching row in the output array: if it doesn't exist then create it
If Not dict.exists(k) Then
dict(k) = rOut '<< associate the key with a row in the output array
'populate the key columns in the output array
For c = 0 To UBound(arrKeyCols)
arrOut(rOut, arrKeyCols(c)) = arr(r, arrKeyCols(c))
Next c
r2 = rOut
rOut = rOut + 1 '<< for the next new key
End If
r2 = dict(k) '<< use this row for populating "values" columns
'build the "value" column(s) from arrValueCols
For c = 0 To UBound(arrValueCols)
v = arrOut(r2, arrValueCols(c)) 'extract the existing value
v = v & IIf(Len(v) > 0, ",", "") & arr(r, arrValueCols(c))
arrOut(r2, arrValueCols(c)) = v 're-add the appended value
Next c
Next r
Summarize = arrOut
End Function