创建独特的元素列表，并通过逗号和en-dash解析显示组成员。

Question

我是一个Excel VBA新手，我想知道如何在一列中创建一个唯一的名称列表，并在下一列中创建相关的组名。

例如，名称 "cds "是以下组的成员。"group1", "group3", "group4", "group5", "group6". 我希望输出结果能显示出来:

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

我在一个不同的留言板上找到了一个Macro 可以显示唯一的元素和相关联的元素 集团编号 而不是 集团名称. 连续的组号中的成员资格用横线表示，否则组号用逗号分隔。

下面的示例输出显示了我从另一个电子表格中复制并粘贴的名称和相关组号的列表。宏创建了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

Answer 1

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

我使用了 VLookup 工作表函数，但是，根据您的数据大小和运行速度，有更快的例程（特别是对于排序的列表）。

由于原来的代码没有按排序顺序输出名称，我没有这样做。但它的实现应该相当简单。一种方法是使用 SortedList 对象。

编辑。 正如@T. M. 在下面的评论中指出的那样 这个例程中存在一个错误 这个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