Выбор уникальных значений в Microsoft Office Excel

Sub GroupByResult()
    Dim z, i&
    z = Range("B4:C" & Range("C" & Rows.Count).End(xlUp).Row).Value
    With CreateObject("scripting.dictionary"): .comparemode = 1
        For i = 1 To UBound(z)
           If Len(.Item(z(i, 1))) > 0 Then
             .Item(z(i, 1)) = .Item(z(i, 1)) & ","
           End If
           .Item(z(i, 1)) = .Item(z(i, 1)) & z(i, 2)
        Next i
    Range("F16").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
   End With
End Sub

Sub GroupByResult2()
    Dim z, i&, syscol As Object

    z = Range("B4:C" & Range("C" & Rows.Count).End(xlUp).Row).Value
    Set syscol = CreateObject("System.Collections.ArrayList")
    With CreateObject("scripting.dictionary"): .comparemode = 1
        For i = 1 To UBound(z)
            .Item(z(i, 1)) = .Item(z(i, 1)) & ", " & z(i, 2)
            If Not syscol.Contains(z(i, 1)) Then syscol.Add z(i, 1)
        Next i

        syscol.Sort: i = 0

        ReDim a(1 To .Count, 1 To 3)
        For i = 1 To UBound(a)
            a(i, 1) = i
            a(i, 2) = syscol(i - 1)
            a(i, 3) = Mid(.Item(a(i, 2)), 3)
        Next

        Range("F16").Resize(.Count, 3).Value = a
    End With
End Sub