How to combine different strings of text for each unique ID into 1 line

The image below shows an example table of data (columns A to B), and the table on the right (columns E to F) shows my desired output.

There can be any number of the same ID. The data can be replicated many times in the same ID and also include different data.
I need to combine all the different DATA items for each ID.

The data items will be comma separated if more than one data item, and can be a mixture of numbers and letters of multiple lengths (even though my example shows single characters). The required data is always between each comma, where commas exist (except for single data items).

The IDs are numerical.

Combine Unique and Delimited Data Using a Dictionary of Dictionaries

Option Explicit

Sub CombineData()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sDelimiter As String = ", "
    ' Destination
    Const dName As String = "Sheet1"
    Const dFirstCellAddress As String = "E2"
    Const dDelimiter As String = ", "
    
    ' Source range to an array.
    
    Dim Data As Variant
    Dim rCount As Long
    
    With ThisWorkbook.Worksheets(sName).Range("A1").CurrentRegion
        rCount = .Rows.Count - 1
        If rCount < 1 Then Exit Sub ' no data or only headers
        Data = .Resize(rCount, 2).Offset(1).Value
    End With
    
    ' Array to a dictionary of dictionaries.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim Item As Variant
    Dim r As Long
    Dim n As Long
    
    For r = 1 To rCount
        Item = CStr(Data(r, 2))
        If Not IsError(Item) Then
            If Len(Item) > 0 Then
                Key = Data(r, 1)
                If Not IsError(Key) Then
                    If Len(Key) > 0 Then
                        Item = Split(Item, sDelimiter)
                        If Not dict.Exists(Key) Then
                            Set dict(Key) = CreateObject("Scripting.Dictionary")
                        End If
                        For n = 0 To UBound(Item)
                            dict(Key)(Item(n)) = Empty
                        Next n
                    End If
                End If
            End If
        End If
    Next r

    rCount = dict.Count
    If rCount = 0 Then Exit Sub ' only error values or blanks
     
    ' Dictionary of dictionaries to the array.
    
    ReDim Data(1 To rCount, 1 To 2)
    r = 0
    
    For Each Key In dict.Keys
        r = r + 1
        Data(r, 1) = Key
        Data(r, 2) = Join(dict(Key).Keys, dDelimiter)
    Next Key
    
    ' Array to the destination range.
    
    With ThisWorkbook.Worksheets(dName).Range(dFirstCellAddress).Resize(, 2)
        .Resize(rCount).Value = Data
        .Resize(.Worksheet.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
    End With

    MsgBox "Data combined.", vbInformation

End Sub