各科排名、各班各科前N名、年级各科前N名

sunshuangzhong

求助各位大佬：求各科排名、各班各科前N名、年级各科前N名

3190496160

一个浩大的工程，
九门，五门，四门，三门如何定义？？

sunshuangzhong

总分怎么算的不用考虑，就当它是门学科名。成绩表中有什么字段名就计算下名次就行了。

WANT-T

sunshuangzhong 发表于 2023-4-7 13:31
总分怎么算的不用考虑，就当它是门学科名。成绩表中有什么字段名就计算下名次就行了。

描述一下口径吧，年名，班名啥的？

sunshuangzhong

过会我来重新上传下真实的模拟结果。年名就是在所有学生中的排名，班名就是在班级里的排名

sunshuangzhong

上传真实模拟结果

grf1973

工作量确实很大。可以用数据库方法生成中间表，包括各科班名、年名。然后通过考号匹配把排名表。
全要用字典的话代码会很长。

grf1973

思路是对于每个科目，按班级+得分（倒序）排序，未参加考试的不计入排名。
同一班级的，从上往下数即得班名
年级排名用rank函数即可。

WANT-T

grf1973 发表于 2023-4-7 16:24
工作量确实很大。可以用数据库方法生成中间表，包括各科班名、年名。然后通过考号匹配把排名表。
全要用字 ...

新手最爱用数组循环加字典，因为所有的教程里都是这么教的；
祝您生活愉快

chxw68

排名代码。

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 d1 = CreateObject("scripting.dictionary")
   
8.     Set d2 = CreateObject("scripting.dictionary")
   
9.     Set d3 = CreateObject("scripting.dictionary")
   
10.     With Worksheets("成绩")
    
11.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
13.         arr = .Range("a1").Resize(r, c)
    
14.     End With
    
15.     ReDim brr(1 To UBound(arr), 1 To (UBound(arr, 2) - 5) * 3)
    
16.     For j = 6 To UBound(arr, 2)
    
17.         n = j * 3 - 17
    
18.         brr(1, n) = arr(1, j) & "年名"
    
19.         brr(1, n + 1) = arr(1, j) & "文理名"
    
20.         brr(1, n + 2) = arr(1, j) & "班名"
    
21.         d1.RemoveAll
    
22.         d2.RemoveAll
    
23.         d3.RemoveAll
    
24.         For i = 2 To UBound(arr)
    
25.             If Len(arr(i, j)) <> 0 Then
    
26.                 d1(arr(i, j)) = d1(arr(i, j)) + 1
    
27.                 If Not d2.exists(arr(i, 5)) Then
    
28.                     Set d2(arr(i, 5)) = CreateObject("scripting.dictionary")
    
29.                 End If
    
30.                 d2(arr(i, 5))(arr(i, j)) = d2(arr(i, 5))(arr(i, j)) + 1
    
31.                 If Not d3.exists(arr(i, 2)) Then
    
32.                     Set d3(arr(i, 2)) = CreateObject("scripting.dictionary")
    
33.                 End If
    
34.                 d3(arr(i, 2))(arr(i, j)) = d3(arr(i, 2))(arr(i, j)) + 1
    
35.             End If
    
36.         Next
    
37.         nn = 1
    
38.         kk = d1.keys
    
39.         For k = 0 To UBound(kk)
    
40.             mm = Application.Large(kk, k + 1)
    
41.             ss = d1(mm)
    
42.             d1(mm) = nn
    
43.             nn = nn + ss
    
44.         Next
    
45.         For Each aa In d2.keys
    
46.             nn = 1
    
47.             kk = d2(aa).keys
    
48.             For k = 0 To UBound(kk)
    
49.                 mm = Application.Large(kk, k + 1)
    
50.                 ss = d2(aa)(mm)
    
51.                 d2(aa)(mm) = nn
    
52.                 nn = nn + ss
    
53.             Next
    
54.         Next
    
55.         For Each aa In d3.keys
    
56.             nn = 1
    
57.             kk = d3(aa).keys
    
58.             For k = 0 To UBound(kk)
    
59.                 mm = Application.Large(kk, k + 1)
    
60.                 ss = d3(aa)(mm)
    
61.                 d3(aa)(mm) = nn
    
62.                 nn = nn + ss
    
63.             Next
    
64.         Next
    
65.         For i = 2 To UBound(arr)
    
66.             If Len(arr(i, j)) <> 0 Then
    
67.                 brr(i, n) = d1(arr(i, j))
    
68.                 brr(i, n + 1) = d2(arr(i, 5))(arr(i, j))
    
69.                 brr(i, n + 2) = d3(arr(i, 2))(arr(i, j))
    
70.             End If
    
71.         Next
    
72.     Next
    
73.     With Worksheets("排名")
    
74.         .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
75.         .Cells(1, UBound(arr, 2) + 1).Resize(UBound(brr), UBound(brr, 2)) = brr
    
76.         With .Range("a1").Resize(UBound(arr), UBound(arr, 2) + UBound(brr, 2))
    
77.             .Borders.LineStyle = xlContinuous
    
78.             With .Font
    
79.                 .Name = "微软雅黑"
    
80.                 .Size = 10
    
81.             End With
    
82.             .HorizontalAlignment = xlCenter
    
83.             .VerticalAlignment = xlCenter
    
84.         End With
    
85.         .Columns(1).Resize(, UBound(arr, 2) + UBound(brr, 2)).AutoFit
    
86.             
    
87.     End With
    
88.     Application.ScreenUpdating = True
    
89.    
    
90. End Sub
    

复制代码