下面是一个 VBA 例程，对于该数量的条目应该可以快速运行。我们创建一个类模块（用户定义对象），其中包含与每个 ID 关联的颜色集合（字典）以及该颜色的计数。 （实际上并不需要计数，但添加它很简单，以防万一您需要它用于其他目的；也可以作为一些可以完成的操作的演示）。
然后我们在相邻列中输出结果，如屏幕截图所示。结果可以输出到其他地方，甚至可以输出到不同的工作表上，只需更改少量代码即可。
请务必阅读模块开头的注释，以获取重要信息以及有关正确设置的信息。
班级模块
Option Explicit
'RENAME this module: cID
Private pID As String
Private pColor As String
Private pColors As Dictionary
Public Property Get ID() As String
ID = pID
End Property
Public Property Let ID(Value As String)
pID = Value
End Property
Public Property Get Color() As String
Color = pColor
End Property
Public Property Let Color(Value As String)
pColor = Value
End Property
Public Property Get Colors() As Dictionary
Set Colors = pColors
End Property
Public Function ADDColor(Value As String)
'Might as well also count # of times this color assigned
If Not pColors.Exists(Value) Then
pColors.Add Key:=Value, Item:=1
Else
pColors(Value) = pColors(Value) + 1
End If
End Function
Private Sub Class_Initialize()
Set pColors = New Dictionary
End Sub
常规模块
EDIT (编辑以消除空白行的计数)
Option Explicit
'Set reference to Microsoft Scripting Runtime (Tools/References)
Sub IDColorCount()
Dim cID As cID, dID As Dictionary
Dim wsData As Worksheet, rData As Range
Dim vData As Variant, vRes As Variant
Dim I As Long
'Set the data worksheet and range
'Read the data into an array for faster calculations
Set wsData = Worksheets("sheet1")
With wsData
Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
vData = rData
End With
'Go through the data and collect the information
Set dID = New Dictionary
For I = 2 To UBound(vData, 1)
If Not vData(I, 1) = "" Then
Set cID = New cID
With cID
.ID = vData(I, 1)
.Color = vData(I, 2)
.ADDColor .Color
If Not dID.Exists(.ID) Then
dID.Add Key:=.ID, Item:=cID
Else
dID(.ID).ADDColor .Color
End If
End With
End If
Next I
'Size the results array
ReDim vRes(1 To UBound(vData), 1 To 1)
vRes(1, 1) = "Count"
For I = 2 To UBound(vData, 1)
If Not vData(I, 1) = "" Then _
vRes(I, 1) = dID(CStr(vData(I, 1))).Colors.Count
Next I
'The results can be written anyplace
With rData.Offset(0, 2).Resize(columnsize:=1)
.EntireColumn.Clear
.Value = vRes
End With
End Sub
