Create List of unique elements and display group membership parsed by commas and en-dash

I'm an Excel VBA newbie and I'm trying to figure out how to create a unique list of names in one column with associated group names in the next column.

For example, the Name "cds" is a member of the following groups: "group1","group3","group4","group5", and "group6". I would like the output to show:

  |Column D   | Column E                 |
     cds          group1, group3–group6

I did find a Macro on a different message board that displays the unique element with the associated Group Number(s) instead of Group Name(s). Membership in consecutive group numbers are represented by the en-dash, otherwise group numbers are separated by commas.

The sample output below shows a list of Names and the associated Group Number which I have copied and pasted from another spreadsheet. The Macro creates the output found in Column D and Column E. Given the key shown in Columns G and H, Is it possible to replace the associated group numbers in Column E with the "Group Name" found in Column H? Thanks for your help!

       |Column A | Column B | Column C | Column D       | Column E  | Column F | Column G     |   Column H        |
Row 1    NAME       GROUP #              NAME (UNIQUE)    GROUP(#s)              Group # (Key)   Group Name (Key)
Row 2    cds         1                     abc             1, 9-10                   1            group1
Row 3    cds         3                     cds             1, 3, 4-6                 2            group2a
Row 4    cds         4                     xyz             7-8                       3            group3
Row 5    cds         5                     zzz             10                        4            group4b
Row 6    cds         6                                                               5            group5
Row 7    abc         10                                                              6            group6
Row 8    abc         9                                                               7            group7
Row 9    xyz         7                                                               8            group8_1
Row 10   xyz         8                                                               9            group9_Z
Row 11   zzz         10                                                              10           group10A

Here is the associated code I used:

Sub OrganizeByNumber()

Dim a, i As Long, e, x, temp, buff

a = Range("a2").CurrentRegion.Value

With CreateObject("Scripting.Dictionary")
   For i = 2 To UBound(a, 1)
     If Not .exists(a(i, 1)) Then
        Set .Item(a(i, 1)) = _
        CreateObject("System.Collections.ArrayList")
     End If
    .Item(a(i, 1)).Add a(i, 2)
   Next

   For Each e In .keys
     .Item(e).Sort
     x = .Item(e).ToArray
     temp = x(0) & Chr(150)

       If UBound(x) > 0 Then
          For i = 1 To UBound(x)
            If x(i) - x(i - 1) = 1 Then
               buff = x(i)
            Else
              temp = temp & buff
            If temp Like "*" & Chr(150) Then temp = Left$(temp, Len(temp) - 1)
              temp = temp & ", " & x(i) & Chr(150)
              buff = ""
       End If
   Next

     If buff <> "" Then
        temp = temp & buff
     Else
        temp = Left$(temp, Len(temp) - 1)
     End If
       .Item(e) = Array(e, temp)
     Else
       .Item(e) = Array(e, Replace(temp, Chr(150), ""))
     End If
   Next

 Range("d2").Resize(.Count, 2).Value = _
 Application.Transpose(Application.Transpose(.items))

End With

End Sub

Solution

It's just a matter of replacing the code numbers in the string with the matching group name.

I used the VLookup worksheet function, but, depending on the size of your data and the speed with which it runs, there are faster routines (especially with a sorted list).

Since the original code did not output the names in sorted order, I did not do that. But it should be fairly simple to implement. One way would be use the SortedList object.

Edit: As pointed out by @T.M. in the comments below, there is a bug in the routine. The bug is actually in your original code, which I unfortunately assumed was working.

I didn't go into it in detail, but under certain circumstances, the buff variable is not getting cleared.

I have changed the code below to ensure buff is always cleared after processing; and I also added some code to sort the output by Name. The sorting code is taken from the link in the comments below.

EDIT2: Code added to remove instances where Name/Group# might be duplicated.

Option Explicit
Sub OrganizeByNumber()

Dim a, b, i As Long, e, x, temp, buff
Dim d As Object

a = Range("a2").CurrentRegion.Value
b = Range("g2").CurrentRegion.Value

Set d = CreateObject("Scripting.Dictionary")
With d
   For i = 2 To UBound(a, 1)
     If Not .exists(a(i, 1)) Then
        Set .Item(a(i, 1)) = _
        CreateObject("System.Collections.ArrayList")
     End If
    .Item(a(i, 1)).Add a(i, 2)
   Next i

   For Each e In .keys
     .Item(e).Sort

     deDupArrList .Item(e)

     x = .Item(e).ToArray

     'temp = x(0) & Chr(150)
     temp = WorksheetFunction.VLookup(x(0), b, 2, False) & Chr(150)

       If UBound(x) > 0 Then
          For i = 1 To UBound(x)
            If x(i) - x(i - 1) = 1 Then

               'buff = x(i)
               buff = WorksheetFunction.VLookup(x(i), b, 2, False)
            Else
              temp = temp & buff
            If temp Like "*" & Chr(150) Then temp = Left$(temp, Len(temp) - 1)

              'temp = temp & ", " & x(i) & Chr(150)
              temp = temp & ", " & WorksheetFunction.VLookup(x(i), b, 2, False) & Chr(150)

              buff = ""
            End If
          Next i

     If buff <> "" Then
        temp = temp & buff
     Else
        temp = Left$(temp, Len(temp) - 1)
     End If
       .Item(e) = Array(e, temp)
     Else
       .Item(e) = Array(e, Replace(temp, Chr(150), ""))
     End If

   buff = ""
   Next e

   sortDict d

 Range("d2").Resize(.Count, 2).Value = _
 Application.Transpose(Application.Transpose(.items))

End With

End Sub

Sub sortDict(dict As Object)
    Dim i As Long, key, al


    'With CreateObject("System.Collections.SortedList")
    Set al = CreateObject("System.Collections.SortedList")
    With al
        For Each key In dict
            .Add key, dict(key)
        Next
        dict.RemoveAll
        For i = 0 To .keys.Count - 1
            dict.Add .getkey(i), .Item(.getkey(i))
        Next
    End With
End Sub

Sub deDupArrList(arrList As Object)
    Dim i As Long
For i = arrList.Count - 1 To 0 Step -1
    If arrList.indexof(arrList(i), 0) <> i Then arrList.removeat i
Next i

End Sub