标签：VBA，Collection集合
示例工作表如下图1所示。
图1
对于列A和列B中的数据，通过列A中的号码、列B中的名称、以及号码或名称的数量来排序。
第1段代码如下：
代码语言：javascript复制Sub test1()
Dim myList As New Collection
Dim myCell, myColl, myObject, myItem
Dim myKey As String
For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
Set myItem = New Collection
For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value)
myItem.Add Item:=myObject
Next myObject
On Error Resume Next
myList.Add Item:=myItem, Key:=myKey
If Err.Number = 457 Then
On Error GoTo 0
myList(myKey).Add Item:=myItem
End If
End If
Next myCell
For Each myColl In myList
Cells(Rows.Count, "D").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2),myColl.Count - 1)
Next myColl
Range("D1").Resize(, 3) = Array("Table", "Name", "Seats")
End Sub结果如图1中的右侧所示。
第2段代码如下：
代码语言：javascript复制Sub test2()
Dim myList As New Collection
Dim myCell, myArray, myObject, Swap1, Swap2
Dim myKey As String, i As Long, j As Long, s As Long
For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
myArray = Array(myCell.Value, myCell.Offset(0, 1).Value, 1)
On Error Resume Next
myList.Add Item:=myArray, Key:=myKey
If Err.Number = 457 Then
On Error GoTo 0
myObject = myList.Item(myKey)
myObject(2) = myObject(2) 1
myList.Remove myKey
myList.Add Item:=Array(myObject(0), myObject(1), myObject(2)), Key:=myKey
End If
End If
Next myCell
For s = 0 To 2
For i = 1 To myList.Count - 1
For j = i 1 To myList.Count
If myList(i)(s) > myList(j)(s) Then
Swap1 = myList(i)
Swap2 = myList(j)
myList.Add Swap1, Before:=j
myList.Add Swap2, Before:=i
myList.Remove i 1
myList.Remove j 1
End If
Next j
Next i
Range(Choose(s 1, "H", "L", "P") & "1").Resize(, 3) = Array("Table", "Name", "Seats")
For Each myArray In myList
Cells(Rows.Count, Choose(s 1, "H", "L", "P")).End(xlUp).Offset(1, 0).Resize( ,3) = myArray
Next myArray
Next s
End Sub结果如下图2所示。
图2
第3段代码如下：
代码语言：javascript复制Sub test3()
Dim myList As New Collection
Dim myCell, myColl, myObject, Swap1, Swap2
Dim myKey As String, i As Long, j As Long, s As Long
Dim myItem, myCount
For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
Set myItem = New Collection
For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value)
myItem.Add Item:=myObject
Next myObject
On Error Resume Next
myList.Add Item:=myItem, Key:=myKey
If Err.Number = 457 Then
On Error GoTo 0
myList(myKey).Add Item:=myItem
End If
End If
Next myCell
For s = 1 To 2
For i = 1 To myList.Count - 1
For j = i 1 To myList.Count
If myList(i)(s) > myList(j)(s) Then
Set Swap1 = myList(i)
Set Swap2 = myList(j)
myList.Add Swap1, Before:=j
myList.Add Swap2, Before:=i
myList.Remove i 1
myList.Remove j 1
End If
Next j
Next i
Range(Choose(s, "H", "L", "P") & "1").Resize(, 3) = Array("Table", "Name", "Seats")
For Each myColl In myList
Cells(Rows.Count, Choose(s, "H", "L", "P")).End(xlUp).Offset(1, 0).Resize( , 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
Next myColl
Next s
For i = 1 To myList.Count - 1
For j = i 1 To myList.Count
If myList(i).Count > myList(j).Count Then
Set Swap1 = myList(i)
Set Swap2 = myList(j)
myList.Add Swap1, Before:=j
myList.Add Swap2, Before:=i
myList.Remove i 1
myList.Remove j 1
End If
Next j
Next i
Range("P1").Resize(, 3) = Array("Table", "Name", "Seats")
For Each myColl In myList
Cells(Rows.Count, "P").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
Next myColl
End Sub结果与上图2相同。
第4段代码如下：
代码语言：javascript复制Sub test4()
Dim myList As New Collection
Dim myCell, myColl, myObject, Swap1, Swap2
Dim myKey As String, i As Long, j As Long, s As Long
Dim myItem, myError, myCount, myIndex, myRemove
For Each myCell In Range("A1", Cells(Rows.Count, 1).End(xlUp))
If Not myCell.Value = vbNullString And Not myCell.Offset(, 1).Value = vbNullString Then
myKey = myCell.Value & "~" & myCell.Offset(0, 1).Value
Set myItem = New Collection
For Each myObject In Array(myCell.Value, myCell.Offset(0, 1).Value)
myItem.Add Item:=myObject
Next myObject
On Error Resume Next
myError = myList.Item(myKey)
Debug.Print Err.Number
If Err.Number = 5 Then
Err.Clear
myList.Add Item:=myItem, Key:=myKey
Else
Err.Clear
myList(myKey).Add Item:=myItem
End If
End If
Next myCell
For s = 1 To 2
For i = 1 To myList.Count - 1
For j = i 1 To myList.Count
If myList(i)(s) > myList(j)(s) Then
Set Swap1 = myList(i)
Set Swap2 = myList(j)
myList.Add Swap1, Before:=j
myList.Add Swap2, Before:=i
myList.Remove i 1
myList.Remove j 1
End If
Next j
Next i
Range(Choose(s, "H", "L") & "1").Resize(, 3) = Array("Table", "Name", "Seats")
For Each myColl In myList
Cells(Rows.Count, Choose(s, "H", "L")).End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
Next myColl
Next s
For i = 1 To myList.Count - 1
For j = i 1 To myList.Count
If myList(i).Count > myList(j).Count Then
Set Swap1 = myList(i)
Set Swap2 = myList(j)
myList.Add Swap1, Before:=j
myList.Add Swap2, Before:=i
myList.Remove i 1
myList.Remove j 1
End If
Next j
Next i
Range("P1").Resize(, 3) = Array("Table", "Name", "Seats")
For Each myColl In myList
Cells(Rows.Count, "P").End(xlUp).Offset(1, 0).Resize(, 3) = Array(myColl(1), myColl(2), myColl.Count - 1)
Next myColl
End Sub结果也与上图2相同。
有兴趣的朋友可以动手试试！
