统计每科前十名数据

准提部林

cui26896 发表于 2022-5-21 22:47
又细做了一下，用归并排序还不如老师的VBA Sort快，快速排序要快一点点，ADO SQL排序转数组输出比归并还要 ...

非不得已, 我才會用數組排序,
尤其是多列多行下, 累積下來的迴圈肯定會慢下來,
能用工作表直接排序, 就儘量用它,
代碼以實用為主, 沒有高下之分~~
__即...易讀//易改...就是好代碼, 除非真的太慢!!

vvw123

我也来班门弄斧，代码全部是褚老师的，只是习惯用竖排，小小的变动

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("成绩")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
12.     arr = .Range("a1").Resize(r, c)
    
13.   End With
    
14.   mc = Application.InputBox(prompt:="请问要取前多少名？", Title:="操作提示", Default:=10, Type:=1)
    
15.   If mc > UBound(arr) - 1 Then
    
16.     mc = UBound(arr) - 1
    
17.   End If
    
18.   For j = 3 To UBound(arr, 2)
    
19.     fs = Application.Large(Application.Index(arr, 0, j), mc)
    
20.     For i = 2 To UBound(arr)
    
21.       If arr(i, j) >= fs Then
    
22.         If Not d.exists(arr(1, j)) Then
    
23.           m = 1
    
24.           ReDim brr(1 To 4, 1 To m)
    
25.         Else
    
26.           brr = d(arr(1, j))
    
27.           m = UBound(brr, 2) + 1
    
28.           ReDim Preserve brr(1 To 4, 1 To m)
    
29.         End If
    
30.         brr(1, m) = arr(i, 1)
    
31.         brr(2, m) = arr(i, 2)
    
32.         brr(3, m) = arr(i, j)
    
33.         d(arr(1, j)) = brr
    
34.       End If
    
35.     Next
    
36.   Next
    
37.   For Each aa In d.keys
    
38.     brr = d(aa)
    
39.     ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
40.     For i = 1 To UBound(brr)
    
41.       For j = 1 To UBound(brr, 2)
    
42.         crr(j, i) = brr(i, j)
    
43.       Next
    
44.     Next
    
45.     d1.RemoveAll
    
46.     For i = 1 To UBound(crr)
    
47.       d1(crr(i, 3)) = d1(crr(i, 3)) + 1
    
48.     Next
    
49.     nn = 1
    
50.     kk = d1.keys
    
51.     For k = 0 To UBound(kk)
    
52.       mm = Application.Large(kk, k + 1)
    
53.       ss = d1(mm)
    
54.       d1(mm) = nn
    
55.       nn = nn + ss
    
56.     Next
    
57.     For i = 1 To UBound(crr)
    
58.       crr(i, 4) = d1(crr(i, 3))
    
59.     Next
    
60.     d(aa) = crr
    
61.   Next
    
62.   With Worksheets("结果")
    
63.     .UsedRange.Offset(1, 0).Clear
    
64.     r1 = 2
    
65.     For Each aa In d.keys
    
66.       brr = d(aa)
    
67.       With .Cells(r1, 1)
    
68.         .Value = aa
    
69.         .Resize(UBound(brr), 1).Merge
    
70.       End With
    
71.       .Cells(r1, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
    
72.       .Cells(r1, 2).Resize(UBound(brr), UBound(brr, 2)).Sort key1:=.Cells(r1, 5), order1:=xlAscending, Header:=xlNo
    
73.       With .Cells(r1, 1).Resize(UBound(brr), 1 + UBound(brr, 2))
    
74.         .Borders.LineStyle = xlContinuous
    
75.         With .Font
    
76.           .Name = "微软雅黑"
    
77.           .Size = 11
    
78.         End With
    
79.       End With
    
80.       r1 = r1 + UBound(brr)
    
81.     Next
    
82.     With .UsedRange
    
83.       .HorizontalAlignment = xlCenter
    
84.       .VerticalAlignment = xlCenter
    
85.     End With
    
86.   End With
    
87.   
    
88.   With Worksheets("结果1")
    
89.     .Cells.Clear
    
90.     n = 1
    
91.     For Each aa In d.keys
    
92.       brr = d(aa)
    
93.       With .Cells(n, 1)
    
94.         .Value = aa
    
95.         .Resize(1, 4).Merge
    
96.       End With
    
97.       .Cells(n + 1, 1).Resize(1, 4) = Array("班级", "姓名", "成绩", "排名")
    
98.       .Cells(n + 2, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
    
99.       .Cells(n + 2, 1).Resize(UBound(brr), UBound(brr, 2)).Sort key1:=.Cells(n, 4), order1:=xlAscending, Header:=xlNo
    
100.       With .Cells(n, 1).Resize(2 + UBound(brr), UBound(brr, 2))
     
101.         .Borders.LineStyle = xlContinuous
     
102.         With .Font
     
103.           .Name = "微软雅黑"
     
104.           .Size = 11
     
105.         End With
     
106.       End With
     
107.       n = n + 2 + UBound(brr)
     
108.     Next
     
109.     With .UsedRange
     
110.       .HorizontalAlignment = xlCenter
     
111.       .VerticalAlignment = xlCenter
     
112.     End With
     
113.   End With
     
114. End Sub
     

复制代码

bow_3s

1. <blockquote>Sub 结果1()

复制代码

bow_3s

1. Sub 结果1()
   
2. 
   
3. Dim r%, c%
   
4. Dim rg As Range
   
5. Dim rg1 As Range
   
6. Dim ws As Worksheet
   
7. 
   
8. Set ws = Worksheets("结果1")
   
9. Set rg = Worksheets("成绩").Range("a1").CurrentRegion
   
10. 
    
11. For c = 3 To 10
    
12.     Worksheets("成绩").Activate
    
13.     rg.Sort key1:=Cells(2, c), order1:=xlDescending, Header:=xlYes
    
14.    
    
15.     Set rg1 = ws.Cells.Find(rg.Cells(1, c)).MergeArea.Cells(1, 1)
    
16.    
    
17.     rg.Range("a2:b" & rg.Rows.Count).Copy rg1.Offset(2, 0)
    
18.     rg.Range(rg.Cells(2, c), rg.Cells(rg.Rows.Count, c)).Copy rg1.Offset(2, 0).Offset(0, 2)
    
19.    
    
20.     r = 3
    
21.     Dim k%
    
22.     k = 0
    
23.     Do While k <= 10
    
24.         If ws.Cells(r, rg1.Column + 2) <> ws.Cells(r - 1, rg1.Column + 2) Then
    
25.             k = k + 1
    
26.         End If
    
27.         ws.Cells(r, rg1.Column + 3) = k
    
28.         r = r + 1
    
29.     Loop
    
30.    
    
31.     ws.Activate
    
32.     ws.Range(Cells(r - 1, rg1.Column), Cells(rg.Rows.Count + 2, rg1.Column + 3)).Delete xlShiftUp
    
33.         
    
34.    
    
35. Next c
    
36. 
    
37. End Sub

复制代码

grf1973

给个全新思路，利用数组下标自然有序，用分数作为数组下标。考虑到有小数出现，用分数*10作为数组下标，从最高到最低数出10个有效分数即可。

grf1973

还可以再优化一点，不用两次split，brr直接记录分数对应的行即可。

grf1973

前面两段是提取了前10个分数，可能不合题意。
这次是提取前10名，若第10名有相同分数，则把相同分数一并提取出来。

qiupan_123

学习了学习了学习了

65861954

countif函数。

micch

学习学习

1. Sub Main()
   
2. '---标准成绩表(ar)，提取各班前几名(m),重分重名
   
3.     Dim d As New Dictionary
   
4.     ar = sheet1.Range("A1:L" & sheet1.Cells(65536, 1).End(xlUp).Row).Value
   
5.     m = 10: n = 1: t = Timer
   
6.     ReDim br(1 To UBound(ar) * 8, 1 To 5)
   
7.     br(1, 1) = "科目": br(1, 2) = "班级"
   
8.     br(1, 3) = "姓名": br(1, 4) = "成绩": br(1, 5) = "排名"
   
9.     For j = 3 To 11
   
10.         For i = 2 To UBound(ar)
    
11.             ar(i, 12) = ar(i, 1) * 10000 - ar(i, j) * 10
    
12.         Next
    
13.         Call SortAr(ar, 12)
    
14.         
    
15.         s = ar(1, j)
    
16.         Set d(s) = New Dictionary
    
17.         For i = 2 To UBound(ar)
    
18.             cls = ar(i, 1)
    
19.             v = ar(i, j)
    
20.             If cls <> ar(i - 1, 1) Then Set d(s)(cls) = New Dictionary
    
21.             If d(s)(cls).Count < m Then
    
22.                 d(s)(cls)(v) = i
    
23.                 n = n + 1
    
24.                 br(n, 1) = ar(1, j)
    
25.                 br(n, 2) = ar(i, 1)
    
26.                 br(n, 3) = ar(i, 2)
    
27.                 br(n, 4) = ar(i, j)
    
28.                 br(n, 5) = d(s)(cls).Count
    
29.             End If
    
30.         Next
    
31.     Next
    
32.     Application.DisplayAlerts = False
    
33.     With Sheet2
    
34.         .Cells.Clear
    
35.         .Range("a1:e" & n).Value = br
    
36.         .Range("a1:e" & n).Borders.LineStyle = xlContinuous
    
37.         For i = 2 To UBound(br) - 1
    
38.             If br(i - 1, 1) <> br(i, 1) Then
    
39.                     If i > 2 Then .Cells(r1, 1).Resize(n1).Merge
    
40.                     r1 = i: n1 = 1
    
41.             Else
    
42.                     n1 = n1 + 1
    
43.             End If
    
44.             If br(i - 1, 2) <> br(i, 2) Then
    
45.                     If i > 2 Then .Cells(r2, 2).Resize(n2).Merge
    
46.                     r2 = i: n2 = 1
    
47.             Else
    
48.                     n2 = n2 + 1
    
49.             End If
    
50.         Next
    
51.     End With
    
52.     Application.DisplayAlerts = True
    
53.     MsgBox Format(Timer - t, "0.00")
    
54. End Sub
    
55. Function SortAr(ar, c, Optional s As Integer = 1)
    
56.     Dim t As Boolean
    
57.     For i = LBound(ar) To UBound(ar)
    
58.     For j = i + 1 To UBound(ar)
    
59.         t = ar(i, c) > ar(j, c)
    
60.         If s = 0 Then t = Not t
    
61.         If t Then
    
62.             For k = LBound(ar, 2) To UBound(ar, 2)
    
63.                 x = ar(i, k)
    
64.                 ar(i, k) = ar(j, k)
    
65.                 ar(j, k) = x
    
66.             Next
    
67.         End If
    
68.     Next
    
69.     Next
    
70.     SortAr = ar
    
71. End Function
    

复制代码