Свести таблицу с учетом регистра (удаление дубликатов, слияние столбцов, Excel)

Sub bb()
Dim v(), w(), i&, k&, d$(), s$, di As Object, x
  Set di = CreateObject("scripting.dictionary")
  di.comparemode = vbTextCompare
  Cells.Sort [A1], xlAscending, Header:=xlYes
  v = Range("B1", Cells(Rows.Count, "A").End(xlUp).Offset(1)).Value2
  ReDim w(1 To UBound(v), 1 To 2)
  For i = 1 To UBound(v)
    If StrComp(v(i, 1), s, vbTextCompare) Then
      k = k + 1
      w(k, 1) = s
      w(k, 2) = Join(di.keys, ", ")
      di.RemoveAll
      s = v(i, 1)
    End If
    For Each x In Split(v(i, 2), ",")
      If Len(x) Then di(x) = 0
    Next
  Next
  Worksheets.Add(, ActiveSheet).Cells(1, 1).Resize(k, 2).Value = w
End Sub

Sub bb1()
Dim v(), w(), i&, k&, d$(), s$, di As Object, x
  Set di = CreateObject("scripting.dictionary")
  Cells.Sort [A1], xlAscending, Header:=xlYes
  v = Range("B1", Cells(Rows.Count, "A").End(xlUp).Offset(1)).Value2
  ReDim w(1 To UBound(v), 1 To 2)
  For i = 1 To UBound(v)
    If v(i, 1) <> s Then
      k = k + 1
      w(k, 1) = s
      w(k, 2) = Join(di.keys, ", ")
      di.RemoveAll
      s = v(i, 1)
    End If
    For Each x In Split(v(i, 2), ",")
      If Len(x) Then di(x) = 0
    Next
  Next
  Worksheets.Add(, ActiveSheet).Cells(1, 1).Resize(k, 2).Value = w
End Sub