How to concatenate more than one column at the same time in excel using VBA

Question

I know how to concatenate when we're dealing with only one column.

Example:

Number Color
1      blue
1      red
1      pink
2      yelow
2      blue
3      red

result:

Number Color
1      blue, red, pink
2      Yellow, blue
3      red

---

This is the code i'm using and it works:

Sub ConcatenateCellsIfSameValues()
    Dim xCol As New Collection
    Dim xSrc As Variant
    Dim xRes() As Variant
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    xSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
    Set xRg = Range("D1")
    On Error Resume Next
    For I = 2 To UBound(xSrc)
        xCol.Add xSrc(I, 1), TypeName(xSrc(I, 1)) & CStr(xSrc(I, 1))
    Next I
    On Error GoTo 0
    ReDim xRes(1 To xCol.Count + 1, 1 To 2)
    xRes(1, 1) = "No"
    xRes(1, 2) = "Combined Color"
    For I = 1 To xCol.Count
        xRes(I + 1, 1) = xCol(I)
        For J = 2 To UBound(xSrc)
            If xSrc(J, 1) = xRes(I + 1, 1) Then
                xRes(I + 1, 2) = xRes(I + 1, 2) & ", " & xSrc(J, 2)
            End If
        Next J
        xRes(I + 1, 2) = Mid(xRes(I + 1, 2), 2)
    Next I
    Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
    xRg.NumberFormat = "@"
    xRg = xRes
    xRg.EntireColumn.AutoFit
End Sub

---

But, I would like to concatenate something like this:

to something like this:

ADDITIONAL EXAMPLE WITH DATE:

Answer 1

Here is how I would approach this, using a Dictionary , in my case Late Binding :

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: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, 4).Resize(, 2).Value = Split(dict.keys()(x), "|")
        .Cells(x + 2, 6).Value = dict.items()(x)
    Next x

End With

End Sub