Добавление уникальных данных в словарь через запятую

Dim dicDom 'ïåðåìåííàÿ ñëîâàðÿ
Dim keyNum As Variant 'ïåðåìåííàÿ äëÿ äîãîâîðà
Dim a(), i&
  Set dicDom = CreateObject("Scripting.Dictionary")
  a = ActiveSheet.UsedRange.Value
  For i = 1 To UBound(a)
      keyNum = CStr(a(i, 1)) 'ïîëó÷àåì êëþ÷
      If Not keyNum Like dicDom(keyNum) Then
      dicDom(keyNum) = dicDom(keyNum) & ", " & a(i, 2) 'äîáàâëÿåì çíà÷åíèå ýëåìåíòà
      End If
  Next i
  ReDim b$(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a) 'âûãðóæàåì ýëåìåíòû èç ñëîâàðÿ ïî óñëîâèþ
    b(i, 1) = Mid$(dicDom(CStr(a(i, 1))), 2)
  Next i
  Range("C1").Resize(UBound(b)).Value = b

Sub В_одну_ячейку()
Dim dicDom 'переменная словаря
Dim keyNum As Variant 'переменная для договора
Dim a(), i&
  Set dicDom = CreateObject("Scripting.Dictionary")
  a = ActiveSheet.UsedRange.Value
  For i = 1 To UBound(a)
      keyNum = CStr(a(i, 1)) 'получаем ключ
      If InStr(1, dicDom(keyNum), a(i, 2)) = 0 Then dicDom(keyNum) = dicDom(keyNum) & ", " & a(i, 2)   'добавляем значение элемента
  Next i
  ReDim b$(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a) 'выгружаем элементы из словаря по условию
    b(i, 1) = Mid$(dicDom(CStr(a(i, 1))), 2)
  Next i
  Range("C1").Resize(UBound(b)).Value = b
End Sub