我有一个两难的境地，我不确定如何正面接近。我有三个班级
一个Segment类，它有一个Customer类的字典，而这些类又包含Product类的字典。 Customer类的字典需要按SumPoundsSold的属性进行排序。
老实说，我不知道从哪里开始。任何提示？
我已经弄明白并在下面回答。还要感谢ainwood发布Chip Pearson的代码来整理收藏/词典！
答案 0 :(得分：1)
Chip Pearson有This really good page on VBA Dictionaries。它包括如何将集合，数组和范围转换为字典（或相互之间），以及如何对字典进行排序。
字典排序的代码（很长！）如下：
使用：
Public Sub SortDictionary(Dict As Scripting.Dictionary, _
SortByKey As Boolean, _
Optional Descending As Boolean = False, _
Optional CompareMode As VbCompareMethod = vbTextCompare)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortDictionary
' This sorts a Dictionary object. If SortByKey is False, the
' the sort is done based on the Items of the Dictionary, and
' these items must be simple data types. They may not be
' Object, Arrays, or User-Defined Types. If SortByKey is True,
' the Dictionary is sorted by Key value, and the Items in the
' Dictionary may be Object as well as simple variables.
'
' If sort by key is True, all element of the Dictionary
' must have a non-blank Key value. If Key is vbNullString
' the procedure will terminate.
'
' By defualt, sorting is done in Ascending order. You can
' sort by Descending order by setting the Descending parameter
' to True.
'
' By default, text comparisons are done case-INSENSITIVE (e.g.,
' "a" = "A"). To use case-SENSITIVE comparisons (e.g., "a" <> "A")
' set CompareMode to vbBinaryCompare.
'
' Note: This procedure requires the
' QSortInPlace function, which is described and available for
' download at www.cpearson.com/excel/qsort.htm .
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Long
Dim KeyValue As String
Dim ItemValue As Variant
Dim Arr() As Variant
Dim KeyArr() As String
Dim VTypes() As VbVarType
Dim V As Variant
Dim SplitArr As Variant
Dim TempDict As Scripting.Dictionary
'''''''''''''''''''''''''''''
' Ensure Dict is not Nothing.
'''''''''''''''''''''''''''''
If Dict Is Nothing Then
Exit Sub
End If
''''''''''''''''''''''''''''
' If the number of elements
' in Dict is 0 or 1, no
' sorting is required.
''''''''''''''''''''''''''''
If (Dict.Count = 0) Or (Dict.Count = 1) Then
Exit Sub
End If
''''''''''''''''''''''''''''
' Create a new TempDict.
''''''''''''''''''''''''''''
Set TempDict = New Scripting.Dictionary
If SortByKey = True Then
''''''''''''''''''''''''''''''''''''''''
' We're sorting by key. Redim the Arr
' to the number of elements in the
' Dict object, and load that array
' with the key names.
''''''''''''''''''''''''''''''''''''''''
ReDim Arr(0 To Dict.Count - 1)
For Ndx = 0 To Dict.Count - 1
Arr(Ndx) = Dict.Keys(Ndx)
Next Ndx
''''''''''''''''''''''''''''''''''''''
' Sort the key names.
''''''''''''''''''''''''''''''''''''''
QSortInPlace InputArray:=Arr, LB:=-1, UB:=-1, Descending:=Descending, CompareMode:=CompareMode
''''''''''''''''''''''''''''''''''''''''''''
' Load TempDict. The key value come from
' our sorted array of keys Arr, and the
' Item comes from the original Dict object.
''''''''''''''''''''''''''''''''''''''''''''
For Ndx = 0 To Dict.Count - 1
KeyValue = Arr(Ndx)
TempDict.Add Key:=KeyValue, Item:=Dict.Item(KeyValue)
Next Ndx
'''''''''''''''''''''''''''''''''
' Set the passed in Dict object
' to our TempDict object.
'''''''''''''''''''''''''''''''''
Set Dict = TempDict
''''''''''''''''''''''''''''''''
' This is the end of processing.
''''''''''''''''''''''''''''''''
Else
'''''''''''''''''''''''''''''''''''''''''''''''
' Here, we're sorting by items. The Items must
' be simple data types. They may NOT be Objects,
' arrays, or UserDefineTypes.
' First, ReDim Arr and VTypes to the number
' of elements in the Dict object. Arr will
' hold a string containing
' Item & vbNullChar & Key
' This keeps the association between the
' item and its key.
'''''''''''''''''''''''''''''''''''''''''''''''
ReDim Arr(0 To Dict.Count - 1)
ReDim VTypes(0 To Dict.Count - 1)
For Ndx = 0 To Dict.Count - 1
If (IsObject(Dict.Items(Ndx)) = True) Or _
(IsArray(Dict.Items(Ndx)) = True) Or _
VarType(Dict.Items(Ndx)) = vbUserDefinedType Then
Debug.Print "***** ITEM IN DICTIONARY WAS OBJECT OR ARRAY OR UDT"
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Here, we create a string containing
' Item & vbNullChar & Key
' This preserves the associate between an item and its
' key. Store the VarType of the Item in the VTypes
' array. We'll use these values later to convert
' back to the proper data type for Item.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Arr(Ndx) = Dict.Items(Ndx) & vbNullChar & Dict.Keys(Ndx)
VTypes(Ndx) = VarType(Dict.Items(Ndx))
Next Ndx
''''''''''''''''''''''''''''''''''
' Sort the array that contains the
' items of the Dictionary along
' with their associated keys
''''''''''''''''''''''''''''''''''
QSortInPlace InputArray:=Arr, LB:=-1, UB:=-1, Descending:=Descending, CompareMode:=vbTextCompare
For Ndx = LBound(Arr) To UBound(Arr)
'''''''''''''''''''''''''''''''''''''
' Loop trhogh the array of sorted
' Items, Split based on vbNullChar
' to get the Key from the element
' of the array Arr.
SplitArr = Split(Arr(Ndx), vbNullChar)
''''''''''''''''''''''''''''''''''''''''''
' It may have been possible that item in
' the dictionary contains a vbNullChar.
' Therefore, use UBound to get the
' key value, which will necessarily
' be the last item of SplitArr.
' Then Redim Preserve SplitArr
' to UBound - 1 to get rid of the
' Key element, and use Join
' to reassemble to original value
' of the Item.
'''''''''''''''''''''''''''''''''''''''''
KeyValue = SplitArr(UBound(SplitArr))
ReDim Preserve SplitArr(LBound(SplitArr) To UBound(SplitArr) - 1)
ItemValue = Join(SplitArr, vbNullChar)
'''''''''''''''''''''''''''''''''''''''
' Join will set ItemValue to a string
' regardless of what the original
' data type was. Test the VTypes(Ndx)
' value to convert ItemValue back to
' the proper data type.
'''''''''''''''''''''''''''''''''''''''
Select Case VTypes(Ndx)
Case vbBoolean
ItemValue = CBool(ItemValue)
Case vbByte
ItemValue = CByte(ItemValue)
Case vbCurrency
ItemValue = CCur(ItemValue)
Case vbDate
ItemValue = CDate(ItemValue)
Case vbDecimal
ItemValue = CDec(ItemValue)
Case vbDouble
ItemValue = CDbl(ItemValue)
Case vbInteger
ItemValue = CInt(ItemValue)
Case vbLong
ItemValue = CLng(ItemValue)
Case vbSingle
ItemValue = CSng(ItemValue)
Case vbString
ItemValue = CStr(ItemValue)
Case Else
ItemValue = ItemValue
End Select
''''''''''''''''''''''''''''''''''''''
' Finally, add the Item and Key to
' our TempDict dictionary.
TempDict.Add Key:=KeyValue, Item:=ItemValue
Next Ndx
End If
'''''''''''''''''''''''''''''''''
' Set the passed in Dict object
' to our TempDict object.
'''''''''''''''''''''''''''''''''
Set Dict = TempDict
End Sub
请注意QSortInPlace代码的要求。我不会在此处粘贴...您可以从This Link
答案 1 :(得分：0)
我明白了！
我可以发布该类的其余部分，但基本上它只涉及找到集合的最小值和最大值，然后在找到它后将其删除，并重复该过程直到达到0的计数。 / p>
这是我的代码
Public Sub SortByVolume(Optional Descending As Boolean = True)
Dim TempDict As Dictionary
Dim benchMark As Double 'The benchmark to start with and go from there
Dim custCheck As Customer 'Customer to check during the loop
'Make sure the Dictionary isn't nothing
If sCustomers Is Nothing Then Exit Sub
'If the count is 0 or 1 we don't need a sort
If (sCustomers.Count = 0) Or (sCustomers.Count = 1) Then Exit Sub
'Create the temprary dictionary
Set TempDict = New Dictionary
'We need to loop through the Dictionary to get the highest Volume
'The Dictionary will load appending, so to descend we get the minimum value and build up, and vice versa for ascending
If Descending = False Then
benchMark = GetMaxVolume
Else
benchMark = GetMinVolume
End If
'Do everything until the benchmark is matched
'Load everything into the TempDict, removing it from the original
Do While sCustomers.Count > 0
For Each pKey In sCustomers.Keys
Set custCheck = sCustomers(pKey)
If custCheck.SumPoundsSold = benchMark Then
'benchmark has been met. Load this customer into TempDict
TempDict.Add custCheck.Name, custCheck
sCustomers.Remove pKey 'Remove the customer
benchMark = IIf(Descending = True, GetMinVolume, GetMaxVolume)
Set custCheck = Nothing
Exit For
End If
Next pKey
Loop
'Set the Class' customer dictionary to the Temporary Dictionary
Set sCustomers = TempDict
'Set the TempDict to nothing
Set TempDict = Nothing
End Sub
Public Function GetMaxVolume() As Double
Dim highVol As Double: highVol = 0
Dim checkCust As Customer
For Each pKey In sCustomers.Keys
Set checkCust = sCustomers(pKey)
If checkCust.SumPoundsSold > highVol Then
highVol = checkCust.SumPoundsSold
End If
Next pKey
GetMaxVolume = highVol
End Function
Public Function GetMinVolume() As Double
Dim lowVol As Double: lowVol = 1.79769313486232E+307
Dim checkCust As Customer
For Each pKey In sCustomers.Keys
Set checkCust = sCustomers(pKey)
If checkCust.SumPoundsSold <= lowVol Then
lowVol = checkCust.SumPoundsSold
End If
Next pKey
GetMinVolume = lowVol
End Function
答案 2 :(得分：0)
好，您的解决方案可以工作，但是会执行不必要的循环，并使用了不必要的辅助函数...
由于VBA中的排序字典（和集合）有点混乱，因此最好使用用于排序的临时数组。
整个过程将是：
在下面的示例中，我仅添加了一个可选参数，以使您的函数可重用于sCusomters变量以外的客户词典：
Public Function SortByVolume(Optional Descending As Boolean = True, _
Optional dicCustomers As Object = Nothing) As Object
Dim blnInputParam As Boolean
Dim pKey As Variant, I As Integer, J As Integer
Dim arrSort() As Customer, blnSwap as Boolean
Dim cusPosI As Customer, cusCur As Customer
Dim dicTemp As Object
On Error Resume Next
Set SortByVolume = Nothing
' allow to use the function with other customer dictionaries
blnInputParam = True
If dicCustomers Is Nothing Then
blnInputParam = False
Set dicCustomers = sCustomers
End If
' validate
If dicCustomers is Nothing Then Exit Function
If dicCustomers.Count = 0 Then Exit Function
' populate array
ReDim arrSort(dicCustomers.Count - 1)
I = 0
For Each pKey In dicCustomers.Keys
Set arrSort(I) = dicCustomers(pKey)
I = I + 1
Next
' sort array
For I = LBound(arrSort) To UBound(arrSort) - 1
Set cusPosI = arrSort(I)
For J = I + 1 To UBound(arrSort)
Set cusCur = arrSort(J)
blnSwap = _
(Descending AND (cusCur.SumPoundsSold > cusPosI.SumPoundsSold)) OR _
((Not Descending) AND (cusCur.SumPoundsSold < cusPosI.SumPoundsSold)
If blnSwap Then
Set arrSort(J) = cusPosI
Set arrSort(I) = cusCur
Set cusPosI = cusCur
End If
Next
Next
' prepare output dictionary
Set dicTemp = CreateObject("Scripting.Dictionary")
dicTemp.CompareMode = BinaryCompare
For I = LBound(arrSort) To UBound(arrSort)
Set cusPosI = arrSort(I)
dicTemp.Add cusPosI.pKey, cusPosI
Next
' if input param wasn't used, set to default customers' dictionary
If Not blnInputParam Then Set sCustomers = dicTemp
Set SortByVolume = dicTemp
End Function
用法
set myDicOfCustomers = SortByVolume(dicCustomers:=myDicOfCustomers)
set myDicOfCustomers = SortByVolume(Descending:=False, dicCustomers:=myDicOfCustomers)
' and you can still launch it against your default dictionary of customers like this
SortByVolume
SortByVolume Descending:=False
答案 3 :(得分：0)
我知道这是一个旧线程，但我也有此需要，我添加了按某个索引对Array属性进行排序。但这是最后一个可选的arg，它对OP问题也起作用。
因此，尽管我使用了该线程中的内容，但非常有帮助，但我不建议使用Dictionary-已经在纯Collections中内置的大量旧代码...-我主要改编了here和{{3} }。
Public Function SortIt(ByVal col As Collection, ByVal SortPropertyName As String _
, ByVal AsAscending As Boolean, Optional ByVal KeyPropertyName As String _
, Optional ByVal CallByNameArg As Variant) As Collection
Dim this As Object
Dim i As Integer, j As Integer
Dim MinMaxIndex As Integer
Dim MinMax As Variant, thisValue As Variant
Dim SortCondition As Boolean
Dim UseKey As Boolean, thisKey As String
UseKey = (KeyPropertyName <> "")
For i = 1 To col.Count - 1
Set this = col(i)
If IsMissing(CallByNameArg0) Then
MinMax = CallByName(this, SortPropertyName, VbGet)
Else
MinMax = CallByName(this, SortPropertyName, VbGet, CallByNameArg)
End If
MinMaxIndex = i
For j = i + 1 To col.Count
Set this = col(j)
If IsMissing(CallByNameArg0) Then
thisValue = CallByName(this, SortPropertyName, VbGet)
Else
thisValue = CallByName(this, SortPropertyName, VbGet, CallByNameArg)
End If
If (AsAscending) Then
SortCondition = (thisValue < MinMax)
Else
SortCondition = (thisValue > MinMax)
End If
If (SortCondition) Then
MinMax = thisValue
MinMaxIndex = j
End If
Set this = Nothing
Next j
If (MinMaxIndex <> i) Then
Set this = col(MinMaxIndex)
col.Remove MinMaxIndex
If (UseKey) Then
If IsMissing(CallByNameArg0) Then
thisKey = CallByName(this, KeyPropertyName, VbGet)
Else
thisKey = CallByName(this, KeyPropertyName, VbGet, CallByNameArg)
End If
col.Add this, thisKey, i
Else
col.Add this, , i
End If
Set this = Nothing
End If
Set this = Nothing
Next i
Set SortIt = col
End Function
希望它对某人有帮助。