Excel 创建唯一元素列表，并显示由逗号和破折号解析的组成员身份

我是一名Excel VBA新手，我正在尝试找出如何在一列中创建一个唯一的名称列表，并在下一列中创建关联的组名称

例如，名称“cds”是以下组的成员：“组1”、“组3”、“组4”、“组5”和“组6”。 我希望输出显示：

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

我确实在另一个留言板上找到了一个宏，它显示了唯一的元素，其中包含相关的组号，而不是组名。连续组号中的成员资格用破折号表示，否则组号用逗号分隔

下面的示例输出显示了我从另一个电子表格复制和粘贴的名称和关联组号的列表。宏创建D列和E列中的输出。给定G列和H列中显示的键，是否可以将E列中的关联组号替换为H列中的“组名”？谢谢你的帮助

       |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

以下是我使用的相关代码：

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

Sub-OrganizeByNumber（）
暗a，i等于长，e，x，temp，buff
a=范围（“a2”）.CurrentRegion.Value
使用CreateObject（“Scripting.Dictionary”）
对于i=2到UBound（a，1）
如果不存在（a（i，1）），那么
第（a（i，1）项=_
CreateObject（“System.Collections.ArrayList”）
如果结束
增加一（i，2）
下一个
对于每个e In.键
.项目（e）.分类
x=.项目（e）.到阵列
温度=x（0）和温度（150）
如果UBound（x）>0，则
对于i=1到UBound（x）
如果x（i）-x（i-1）=1，那么
buff=x（i）
其他的
温度=温度和增益
如果温度像“*”和Chr（150），那么温度=左$（温度，长度（温度）-1）
温度=温度和“，”和x（i）和Chr（150）
buff=“”
如果结束
下一个
如果buff“”则
温度=温度和增益
其他的
温度=左$（温度，透镜（温度）-1）
如果结束
.项目（e）=阵列（e，温度）
其他的
.Item（e）=数组（e，替换（temp，Chr（150），“”）
如果结束
下一个
范围（“d2”）。调整大小（.Count，2）。值=_
Application.Transpose（Application.Transpose（.items））
以
端接头

只需将字符串中的代码编号替换为匹配的组名即可

我使用了

VLookup

工作表函数，但是，根据数据的大小和运行速度，有更快的例程（尤其是排序列表）

因为原始代码没有按排序顺序输出名称，所以我没有这样做。但实现起来应该相当简单。一种方法是使用

SortedList

对象

编辑：正如@T.M.在下面的评论中指出的，例程中有一个bug。这个bug实际上存在于您的原始代码中，不幸的是，我假设它正在工作

我没有详细说明，但是在某些情况下，

buff

变量没有被清除

我已经更改了下面的代码，以确保处理后始终清除

buff

；我还添加了一些代码，按照

Name

对输出进行排序。排序代码取自下面注释中的

EDIT2:添加代码以删除可能重复的Name/Group.实例

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

选项显式
子组织bynumber（）
暗a、b、i与长e、x、温度、浅黄色相同
将d作为对象
a=范围（“a2”）.CurrentRegion.Value
b=范围（“g2”）。当前区域。值
Set d=CreateObject（“Scripting.Dictionary”）
与d
对于i=2到UBound（a，1）
如果不存在（a（i，1）），那么
第（a（i，1）项=_
CreateObject（“System.Collections.ArrayList”）
如果结束
增加一（i，2）
接下来我
对于每个e In.键
.项目（e）.分类
重复数据列表。项目（e）
x=.项目（e）.到阵列
‘温度=x（0）&Chr（150）
temp=工作表函数VLookup（x（0），b，2，False）和Chr（150）
如果UBound（x）>0，则
对于i=1到UBound（x）
如果x（i）-x（i-1）=1，那么
‘buff=x（i）
buff=WorksheetFunction.VLookup（x（i），b，2，False）
其他的
温度=温度和增益
如果温度像“*”和Chr（150），那么温度=左$（温度，长度（温度）-1）
‘温度=温度&’，“&x（i）&Chr（150）
temp=temp&“，”和工作表函数.VLookup（x（i），b，2，False）和Chr（150）
buff=“”
如果结束
接下来我
如果buff“”则
温度=温度和增益
其他的
温度=左$（温度，透镜（温度）-1）
如果结束
.项目（e）=阵列（e，温度）
其他的
.Item（e）=数组（e，替换（temp，Chr（150），“”）
如果结束
buff=“”
下一个e
sortDict d
范围（“d2”）。调整大小（.Count，2）。值=_
Application.Transpose（Application.Transpose（.items））
以
端接头
子分类目录（dict作为对象）
我和你一样长，钥匙，艾尔
'使用CreateObject（“System.Collections.SortedList”）
Set al=CreateObject（“System.Collections.SortedList”）
和艾尔
对于dict中的每个键
.添加键，dict（键）
下一个
雷莫维尔
对于i=0到.keys.Count-1
目录添加.getkey（i），.Item（.getkey（i））
下一个
以
端接头
子重复arrList（作为对象的arrList）
我想我会坚持多久
对于i=arrList.Count-1到0步骤-1
如果arrList.indexof（arrList（i），0）i，则arrList.removeat i
接下来我
端接头

---

请调查Rubberduck在线压头的VBA，或学习正确缩进您自己的代码。Excel的哪个版本？你需要VBA吗？我更喜欢VBA解决方案。代码需要在Excel 2010、2016和2019中运行。谢谢，谢谢，罗恩！一切都很完美。Vlookup函数的工作速度足够快。你知道我可以学习如何实现SortedList对象的快速链接吗？再次感谢。@byny22看一看m