VBA 数组排序

kaiwozhe

请教一下各位，主要想利用vba内的数组排序，比如 1月1日，我需要2个最大的数，如果在VBA内的数组降序了，我就可以取前两面个求和

冒泡排序试了会很卡，不知道是不是数据很多的问题，大概几十万条左右



参考了一下论坛里面的一个方法，但是这个不知道怎么套用，求帮助

1. 
   
2. <div>Sub test()
   
3.     Dim arr(99)
   
4.     For i = 1 To 10
   
5.         t = Int(Rnd() * 100)
   
6.         arr(t) = t & ";"
   
7.     Next
   
8.     Debug.Print Replace(Join(arr), " ", "")
   
9. End Sub</div>
   

复制代码

lizhipei78

比较简单的一题字典汇总题

songshihai

试试!!!!!!!!!!!!!!!!!!!!!!!!!!!

songshihai

刚刚那个有点问题,改了一下!!!!!!!

kyxfyzg

仅供参考。。。。。。。。。。

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. With Sheet1
   
6.     arr = .Range("a1").CurrentRegion.Value
   
7.     ReDim brr(1 To 10000, 1 To 3)
   
8. For i = 2 To UBound(arr)
   
9.     s = CDate(arr(i, 1))
   
10.     If Not dic.exists(s) Then
    
11.         dic(s) = Val(arr(i, 2))
    
12.     Else
    
13.         dic(s) = dic(s) & "," & Val(arr(i, 2))
    
14.    
    
15.     End If
    
16. Next
    
17. For Each k In dic.keys
    
18.             krr = Split(dic(k), ",")
    
19.         d2.RemoveAll
    
20.         For i = 0 To UBound(krr)
    
21.             m = UBound(krr) - 1
    
22.             For j = 0 To m
    
23.                 If krr(j) < krr(j + 1) Then
    
24.                     temp = krr(j)
    
25.                     krr(j) = krr(j + 1)
    
26.                     krr(j + 1) = temp
    
27.                 End If
    
28.             Next
    
29.         j = j - 1
    
30.         Next
    
31.    
    
32.     For i = 0 To UBound(krr)
    
33.         d2(krr(i)) = krr(i)
    
34.     Next
    
35.     kk = d2.keys
    
36.     n = n + 1
    
37.     brr(n, 1) = k
    
38.     For i = 2 To UBound(arr)
    
39.         If CDate(arr(i, 1)) = k Then
    
40.             If Val(arr(i, 2)) = kk(0) Or Val(arr(i, 2)) = kk(1) Then
    
41.                 brr(n, 2) = brr(n, 2) + 1
    
42.                 brr(n, 3) = brr(n, 3) + Val(arr(i, 2))
    
43.             End If
    
44.         End If
    
45.     Next
    
46. Next k
    
47. .Range("g2").Resize(n, 3) = brr
    
48. End With
    
49. Set dic = Nothing: Set d2 = Nothing
    
50. End Sub
    

复制代码

Qs18

试试。。。。。。。

Qs18

试试.........

Qs18

试试。。。。。。。。。

grf1973

借用部分8楼代码。