multiple lookup values using Dictionary objects in vba

Question

Sheet 1:

Sheet 2:

Expected Result:

Actual Result:

I'm trying to get multiple lookup values using the below mentioned VBA code using dictionary objects but the result is getting corrupted as shown above. Kindly help me to resolve this. Thanks in advance.

Option Explicit

Sub macro1()

    Dim dict As Object, lastrow As Long, r As Long, n As Long
    Dim key As String, t0 As Single: t0 = Timer
    Set dict = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet2")
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            key = Trim(.Cells(r, "A"))
            If dict.Exists(key) Then
                dict(key) = dict(key) & "," & Trim(.Cells(r, "B"))
            ElseIf Len(key) > 0 Then
                dict(key) = Trim(.Cells(r, "B"))
            End If
        Next
    End With

    With Sheets("Sheet1")
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For r = 2 To lastrow
            key = Trim(.Cells(r, "A"))
            If dict.Exists(key) Then
                .Cells(r, "B") = dict(key)
                n = n + 1
            End If
        Next
    End With
    MsgBox n & " Rows updated", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub