Concatenate 3rd column based on another two column

Option Explicit
Sub test1()
    Dim myList As New Collection
    Dim myCell, myColl, myObject, myItem
    Dim myKey As String, myarray As String
    For Each myCell In Range("A2", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItem = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, myCell.Offset(0, 2).Value)
                Call myItem.Add(Item:=myObject)
            Next myObject
            On Error Resume Next
            Call myList.Add(Item:=myItem, key:=myKey)
            If Err.Number = 457 Then
                On Error GoTo 0
                myarray = myList.Item(myKey)(3)
                myList.Remove myKey
                myarray = myarray & myCell.Offset(0, 2).Value
                Set myItem = New Collection
                For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, myarray)
                    Call myItem.Add(Item:=myObject)
                Next myObject
                Call myList.Add(Item:=myItem, key:=myKey)
            End If
        End If
    Next myCell
    For Each myColl In myList
        Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl(3))
    Next myColl
    Range("D1:F1").Value = Range("A1:C1").Value
End Sub

Option Explicit
Sub test_2()
    Dim myList As New Collection, myItems As Collection
    Dim myCell As Range, myColl As Object, myObject As Variant, myName As String
    
    For Each myCell In Range("A2", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myName = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItems = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, CStr(myCell.Offset(0, 2).Value))
                Call myItems.Add(Item:=myObject)
            Next myObject
            On Error Resume Next
            myList.Add Item:=myItems, key:=myName
            If Err.Number = 457 Then
                On Error GoTo 0
                myList.Item(myName).Add myList.Item(myName)(myList.Item(myName).Count) & CStr(myCell.Offset(0, 2).Value)
            End If
        End If
    Next myCell
    For Each myColl In myList
        Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl(myColl.Count))
    Next myColl
    Range("E1:G1").Value = Range("A1:C1").Value
End Sub

Option Explicit
Sub test_3()
    Dim myList As New Collection, myItems As Collection
    Dim myCell As Range, myColl As Object, myObject As Variant, myName As String
    
    Application.ScreenUpdating = False
    Set myList = New Collection
    For Each myCell In Range("A2", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myName = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItems = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, CStr(myCell.Offset(0, 2).Value))
                myItems.Add myObject
            Next myObject
            On Error Resume Next
            myList.Add Item:=myItems, key:=myName
            If Err.Number = 457 Then
                Err.Clear
                myList.Item(myName).Add myList.Item(myName)(myList.Item(myName).Count) & CStr(myCell.Offset(0, 2).Value)
            End If
        End If
    Next myCell
    For Each myColl In myList
        Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl(myColl.Count))
    Next myColl
    Range("E1:G1").Value = Range("A1:C1").Value
     Set myItems = Nothing
     Set myList = Nothing
    Application.ScreenUpdating = True
    
End Sub

Sub test_4()
    Dim myList As New Collection, myItems As Collection
    Dim myCell As Range, myValues As Object, myObject As Variant, myName As String


    Application.ScreenUpdating = False
    Set myList = New Collection
    For Each myCell In Range("A2", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myName = myCell.Value & "~" & myCell.Offset(0, 1).Value
            Set myItems = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, CStr(myCell.Offset(0, 2).Value))
                myItems.Add myObject
            Next myObject
            On Error Resume Next
            myList.Add Item:=myItems, key:=myName
            If Err.Number = 457 Then
                Err.Clear
                myList.Item(myName).Add myList.Item(myName)(3) & CStr(myCell.Offset(0, 2).Value), , 3
            End If
        End If
    Next myCell
    For Each myValues In myList
        Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myValues(1), myValues(2), myValues(3))
    Next myValues
    Range("E1:G1").Value = Range("A1:C1").Value
    Set myItems = Nothing
    Set myList = Nothing
    Application.ScreenUpdating = True


End Sub

Option Explicit
Sub test_5()
    Dim myList As New Collection, myItems As Collection
    Dim myCell As Range, myValues As Object, myObject As Variant, myName As String


    Application.ScreenUpdating = False
    Set myList = New Collection
    For Each myCell In Range("A2", Cells(Rows.Count, 1).End(xlUp))
        If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
            myName = myCell.Value & "~" & myCell.Offset(0, 1).Value
            On Error Resume Next
             Call myList.Item(myName)
            If Err.Number = 5 Then
                Err.Clear
                 Set myItems = New Collection
            For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value, CStr(myCell.Offset(0, 2).Value))
                myItems.Add myObject
            Next myObject
                myList.Add Item:=myItems, key:=myName
             Else
              '  myList.Item(myName).Add myList.Item(myName)(3) & CStr(myCell.Offset(0, 2).Value), , , 2
               myList.Item(myName).Add myList.Item(myName)(3) & CStr(myCell.Offset(0, 2).Value), , 3
               myList.Item(myName).Remove (4)
            End If
        End If
    Next myCell
    For Each myValues In myList
        Cells(Rows.Count, "E").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myValues(1), myValues(2), myValues(3))
    Next myValues
    
    Range("E1:G1").Value = Range("A1:C1").Value
    Set myItems = Nothing
    Set myList = Nothing
    Application.ScreenUpdating = True


End Sub

Option Explicit
Sub test6()
    Dim a(), b(), i As Long, n As Long
    a = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Resize(, 3).Value
    n = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1) & "~" & a(i, 2)) Then
                n = n + 1
                .Add a(i, 1) & "~" & a(i, 2), n
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 2)
                b(n, 3) = a(i, 3)
            Else
                b(.Item(a(i, 1) & "~" & a(i, 2)), 3) = b(.Item(a(i, 1) & "~" & a(i, 2)), 3) & a(i, 3)
            End If
        Next
    End With
    Range("I1").Resize(n, 3).Value = b
    Range("I1:K1").Value = Range("A1:C1").Value
End Sub

Sub test7()
    Dim a(), b(), i As Long, n As Long, myName As String, myList As Collection


    a = Range("A2", Cells(Rows.Count, 1).End(xlUp)).Resize(, 3).Value
    n = 1
    Set myList = New Collection
    With myList
        ReDim b(1 To UBound(a, 1), 1 To 3)
        For i = 1 To UBound(a, 1)
            myName = a(i, 1) & "~" & a(i, 2)
            On Error Resume Next
            Call .Item(myName)
            If Err.Number = 5 Then
                Err.Clear
                .Add Item:=n, key:=myName
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 2)
                b(n, 3) = a(i, 3)
                n = n + 1
            Else
                b(.Item(myName), 3) = b(.Item(myName), 3) & a(i, 3)
            End If
        Next
    End With
    Range("I2").Resize(n, 3).Value = b
    Range("I1:K1").Value = Range("A1:C1").Value
End Sub