这里是一个有些不同的方法。 “唯一行”存储在字典中，但我们也使用类中的字典来存储多个项目（如果它们应该保存在同一行）。完成后，然后将这些项目放在一起，用逗号分隔的字符串。
另外，通过使用这种方法，不需要预先对行进行排序。
可以使用内置的 VBA Collection 对象，但我认为，特别是对于这么多集合，使用 Dictionary 编码会更简单一些。
我们将确定唯一性的两个项目Date 和TicketNumber 组合为key。
请注意，您需要重命名类模块：cRows，并且您还必须添加对 Microsoft Scripting Runtime 的引用。
类模块
Option Explicit
'Rename to cRows
Private pDT As Date
Private pTicket As String
Private pCounty As String
Private pCounties As Dictionary
Private pCode As String
Private pCodes As Dictionary
Private pDescription As String
Private pDescriptions As Dictionary
Private pTyp As String
Private pTyps As Dictionary
Private Sub Class_Initialize()
'use dictionaries to combine multiple items
Set pCounties = New Dictionary
Set pCodes = New Dictionary
Set pDescriptions = New Dictionary
Set pTyps = New Dictionary
End Sub
Public Property Get DT() As Date
DT = pDT
End Property
Public Property Let DT(Value As Date)
pDT = Value
End Property
Public Property Get Ticket() As String
Ticket = pTicket
End Property
Public Property Let Ticket(Value As String)
pTicket = Value
End Property
Public Property Get County() As String
County = pCounty
End Property
Public Property Let County(Value As String)
pCounty = Value
End Property
Public Property Get Counties() As Dictionary
Set Counties = pCounties
End Property
Public Function ADDCounty(Value As String)
If Value <> "" Then
If Not pCounties.Exists(Value) Then _
pCounties.Add Key:=Value, Item:=Value
End If
End Function
Public Property Get Code() As String
Code = pCode
End Property
Public Property Let Code(Value As String)
pCode = Value
End Property
Public Property Get Codes() As Dictionary
Set Codes = pCodes
End Property
Public Function ADDCode(Value As String)
If Value <> "" Then
If Not pCodes.Exists(Value) Then _
pCodes.Add Value, Value
End If
End Function
Public Property Get Description() As String
Description = pDescription
End Property
Public Property Let Description(Value As String)
pDescription = Value
End Property
Public Property Get Descriptions() As Dictionary
Set Descriptions = pDescriptions
End Property
Public Function ADDDescription(Value As String)
If Value <> "" Then
If Not pDescriptions.Exists(Value) Then _
pDescriptions.Add Value, Value
End If
End Function
Public Property Get Typ() As String
Typ = pTyp
End Property
Public Property Let Typ(Value As String)
pTyp = Value
End Property
Public Property Get Typs() As Dictionary
Set Typs = pTyps
End Property
Public Function ADDTyp(Value As String)
If Value <> "" Then
If Not pTyps.Exists(Value) Then _
pTyps.Add Value, Value
End If
End Function
Public Function CombineDicts(Dict As Dictionary) As String
Dim W As Variant, S As String
For Each W In Dict
S = S & "," & Dict(W)
Next W
CombineDicts = Mid(S, 2)
End Function
常规模块
Option Explicit
'Add Reference (Tools/References) to Microsoft Scripting Runtime
Sub DeDupAndCombine()
Dim cR As cRows, dR As Dictionary
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim I As Long, J As Long, V As Variant, W As Variant
Dim sKey As String
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
'Get the Source data
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=6)
End With
'collect and dedup
Set dR = New Dictionary
For I = 2 To UBound(vSrc, 1)
Set cR = New cRows
With cR
.DT = vSrc(I, 2)
.Ticket = vSrc(I, 5)
sKey = .DT & "|" & .Ticket
.County = vSrc(I, 1)
.ADDCounty .County
.Code = vSrc(I, 3)
.ADDCode .Code
.Description = vSrc(I, 4)
.ADDDescription .Description
.Typ = vSrc(I, 6)
.ADDTyp .Typ
If Not dR.Exists(sKey) Then
dR.Add sKey, cR
Else
With dR(sKey)
.ADDCounty cR.County
.ADDCode cR.Code
.ADDDescription cR.Description
.ADDTyp cR.Typ
End With
End If
End With
Next I
'Create the results
ReDim vRes(0 To dR.Count, 1 To 6)
'Headers
For I = 1 To 6
vRes(0, I) = vSrc(1, I)
Next I
'data
I = 0
For Each V In dR
I = I + 1
With dR(V)
vRes(I, 1) = .CombineDicts(.Counties)
vRes(I, 2) = .DT
vRes(I, 3) = .CombineDicts(.Codes)
vRes(I, 4) = .CombineDicts(.Descriptions)
vRes(I, 5) = .Ticket
vRes(I, 6) = .CombineDicts(.Typs)
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
如果速度是个问题，您可以尝试看看执行.RemoveDuplicates 方法是否会导致更快的执行时间。您也可以在写入工作表的段之前关闭ScreenUpdating。