[發問] 物件排序問題"Scripting.Dictionary"

PKKO

想請問各位大大,我Set xd2 = CreateObject("Scripting.Dictionary")
然後下方跑回圈可以得到兩個東西
1:不重複的名稱xd.keys,2:每個名稱出現過的次數

問題是我要如何得到前三名出現過的次數是幾次?以及這前三名是誰?

1. '輸入次數
   
2. for 迴圈
   
3.    xd2(CInt(ar(j))) = xd2(CInt(ar(j))) + 1
   
4. next

複製代碼

小弟寫得出來,但方法很愚昧,想請教各位大大一定有更好的做法
以下為小弟的程式碼(攏長慎入!)
我是先將items轉為另一個陣列,在用陣列進行排序大小,然後再跑回圈如果次數相等,就把名稱取出,肯定有更簡易的方法,因此想問問看各位大大的撰寫方法!

1. '找出最大的三個次數
   
2. aar = Split(Join(xd2.items, ","), ",")
   
3. ReDim cc(0 To UBound(aar), 1 To 1)
   
4. For j = 0 To UBound(aar)
   
5.     cc(j, 1) = CInt(aar(j))
   
6. Next
   
7. a1 = 0: a2 = 0: a3 = 0
   
8. For j = 0 To UBound(aar)
   
9.       If a1 = 0 Then a1 = Application.WorksheetFunction.Large(cc, j + 1)
   
10.       If Application.WorksheetFunction.Large(cc, j + 1) <> a1 And a2 = 0 Then
    
11.           a2 = Application.WorksheetFunction.Large(cc, j + 1)
    
12.       End If
    
13.       If Application.WorksheetFunction.Large(cc, j + 1) <> a1 And Application.WorksheetFunction.Large(cc, j + 1) <> a2 And a3 = 0 Then
    
14.           a3 = Application.WorksheetFunction.Large(cc, j + 1)
    
15.       End If
    
16. Next
    
17. str1 = a1 & "次:": str2 = a2 & "次:": str3 = a3 & "次:"
    
18. For Each e In xd2.keys
    
19.       If xd2(CInt(e)) = a1 Then str1 = str1 & CInt(e) & ","
    
20.       If xd2(CInt(e)) = a2 Then str2 = str2 & CInt(e) & ","
    
21.       If xd2(CInt(e)) = a3 Then str3 = str3 & CInt(e) & ","
    
22. Next
    
23. If a1 <> 0 Then str1 = Left(str1, Len(str1) - 1)
    
24. If a2 <> 0 Then str2 = Left(str2, Len(str2) - 1)
    
25. If a3 <> 0 Then str3 = Left(str3, Len(str3) - 1)

複製代碼

stillfish00

回復 1# PKKO

1. Sub Test()
   
2.     Dim xd2:  Set xd2 = CreateObject("Scripting.Dictionary")
   
3. '    '輸入次數
   
4. '    for 迴圈
   
5. '       xd2(CInt(ar(j))) = xd2(CInt(ar(j))) + 1
   
6. '    Next
   
7.    
   
8.     Dim dicValue2Key: Set dicValue2Key = CreateObject("Scripting.Dictionary")
   
9.     Dim xItem
   
10.     For Each x In xd2.keys
    
11.         xItem = xd2(x)
    
12.         If Not dicValue2Key.exists(xItem) Then
    
13.             dicValue2Key(xItem) = x
    
14.         Else
    
15.             dicValue2Key(xItem) = dicValue2Key(xItem) & "," & x
    
16.         End If
    
17.     Next
    
18.    
    
19.     Debug.Print "最多次: " & dicValue2Key(Application.WorksheetFunction.Large(dicValue2Key.keys, 1))
    
20.     Debug.Print "第二多次: " & dicValue2Key(Application.WorksheetFunction.Large(dicValue2Key.keys, 2))
    
21.     Debug.Print "第三多次: " & dicValue2Key(Application.WorksheetFunction.Large(dicValue2Key.keys, 3))
    
22. End Sub

複製代碼

准提部林

全部用陣列排序：
Arr = xD2.keys
Brr = xD2.items
Y = xD2.Count
ReDim Crr(1 To Y, 1 To 2)
For i = 1 To Y
　　For j = i - 1 To 1 Step -1
　　　　If Brr(i - 1) < Crr(j, 2) Then Exit For
　　　　Crr(j + 1, 1) = Crr(j, 1)
　　　　Crr(j + 1, 2) = Crr(j, 2)
　　Next j
　　　　Crr(j + 1, 1) = Arr(i - 1)
　　　　Crr(j + 1, 2) = Brr(i - 1)
Next i
[F1:G1].Resize(Y) = Crr　'列出全部
[H1:I1].Resize(3) = Crr　'列出前三多

PKKO

感謝兩位大大的回覆,都是很有意思的思維,小弟會好好研讀一下!先謝謝大大們了!