XL 2013 Cmt afficher des valeurs liées à la suite dans une seule cellule

Sub Fournisseurs()
Dim s$, t, rest$(), d As Object, i&, x$, y$, z$
s = ", " 'séparateur, à adapter
t = ActiveSheet.UsedRange.Resize(, 2)
ReDim rest(1 To UBound(t), 1 To 1)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  x = t(i, 1): y = t(i, 2)
  If x <> "" And y <> "" Then
    If Not d.exists(x) Then d(x) = i 'repère la ligne
    z = rest(d(x), 1)
    If InStr(s & z & s, s & y & s) = 0 Then _
      rest(d(x), 1) = IIf(z = "", "", z & s) & y
  End If
Next
ActiveSheet.[C1].Resize(UBound(t)) = rest
End Sub

Sub synthèse()
    Application.DisplayAlerts = False
    Dim f As Worksheet
    Dim dico As Object

    For Each f In Worksheets
        If f.Name = "Synthèse" Then f.Delete
    Next f

    Set dico = CreateObject("scripting.dictionary")
    dico.comparemode = 1

    a = Feuil1.UsedRange
    For i = 2 To UBound(a)
        If Not dico.exists(a(i, 1)) Then
            dico.Item(a(i, 1)) = a(i, 2)
        Else
            If InStr(1, dico.Item(a(i, 1)), a(i, 2), vbTextCompare) = 0 Then
                dico.Item(a(i, 1)) = dico.Item(a(i, 1)) & "," & a(i, 2)
            End If
        End If
    Next i
    Sheets.Add after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Synthèse"
    With Sheets("Synthèse")
        .Cells(1, 1).Resize(1, 2) = Array(a(1, 1), a(1, 2))
        .Cells(2, 1).Resize(dico.Count) = Application.Transpose(dico.keys)
        .Cells(2, 2).Resize(dico.Count) = Application.Transpose(dico.items)
        .Columns("A:B").AutoFit
    End With

    Set dico = Nothing
    Set f = Nothing
    Application.DisplayAlerts = True
End Sub