VBA 数组排序

Qs18

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

复制代码

grf1973

直觉这样速度会更快一点。可以拿10几万数据试试。

dragonthree

grf1973 发表于 2024-9-18 15:28
直觉这样速度会更快一点。可以拿10几万数据试试。

这没考虑最大值，次大值有重复的吧

grf1973

dragonthree 发表于 2024-9-18 15:30
这没考虑最大值，次大值有重复的吧

哦，对。把>改成>=即可

Qs18

调整了一下........

Qs18

调整了一下.........

grf1973

grf1973 发表于 2024-9-18 15:32
哦，对。把>改成>=即可

不对，不用改。要改也只能改第2个大于号，第一个大于号改了就错了。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.9.18
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     Set List = CreateObject("System.Collections.ArrayList")
   
5.     ReDim brr(1 To 10000, 1 To 2)
   
6.     With Sheets("Sheet1")
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         arr = .[a1].Resize(r, 2)
   
9.         For i = 2 To UBound(arr)
   
10.             s = arr(i, 1)
    
11.             d(s) = ""
    
12.         Next
    
13.         For Each k In d.keys
    
14.             List.Clear
    
15.             m = m + 1
    
16.             n = 0
    
17.             d1.RemoveAll
    
18.             For i = 2 To UBound(arr)
    
19.                 If arr(i, 1) = k Then If Not List.Contains(arr(i, 2)) Then List.Add arr(i, 2)
    
20.             Next
    
21.             List.Sort
    
22.             List.Reverse
    
23.             zrr = List.toArray
    
24.             For x = 0 To 1
    
25.                 d1(zrr(x)) = ""
    
26.             Next
    
27.             For i = 2 To UBound(arr)
    
28.                 If arr(i, 1) = k And d1.exists(arr(i, 2)) Then n = n + 1
    
29.             Next
    
30.             brr(m, 1) = k
    
31.             brr(m, 2) = n
    
32.         Next
    
33.         .[g2].Resize(m, 2) = brr
    
34.     End With
    
35.     MsgBox "OK！"
    
36. End Sub
    

复制代码

kaiwozhe

grf1973 发表于 2024-9-18 15:28
直觉这样速度会更快一点。可以拿10几万数据试试。

感谢帮助，不过可能是我没表达好，日期和每天应取的数量是需要按照我原表的，

比如是
1月1日   需要2票
1月2日   需要4票
1月3日  需要7票