问题
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
回答1:
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
来源：https://stackoverflow.com/questions/62111013/create-list-of-unique-elements-and-display-group-membership-parsed-by-commas-and