统计每科前十名数据

vivian0526 · 发表于 2022-5-20 15:35

总成绩表中统计出每科前十名学生的信息。有并列全部取。

chxw68 · 发表于 2022-5-20 16:01

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("成绩")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
mc = Application.InputBox(prompt:="请问要取前多少名？", Title:="操作提示", Default:=10, Type:=1)
If mc > UBound(arr) - 1 Then
mc = UBound(arr) - 1
End If
For j = 3 To UBound(arr, 2)
fs = Application.Large(Application.Index(arr, 0, j), mc)
For i = 2 To UBound(arr)
If arr(i, j) >= fs Then
If Not d.exists(arr(1, j)) Then
m = 1
ReDim brr(1 To 4, 1 To m)
Else
brr = d(arr(1, j))
m = UBound(brr, 2) + 1
ReDim Preserve brr(1 To 4, 1 To m)
End If
brr(1, m) = arr(i, 1)
brr(2, m) = arr(i, 2)
brr(3, m) = arr(i, j)
d(arr(1, j)) = brr
End If
Next
Next
For Each aa In d.keys
brr = d(aa)
ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
For i = 1 To UBound(brr)
For j = 1 To UBound(brr, 2)
crr(j, i) = brr(i, j)
Next
Next
d1.RemoveAll
For i = 1 To UBound(crr)
d1(crr(i, 3)) = d1(crr(i, 3)) + 1
Next
nn = 1
kk = d1.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d1(mm)
d1(mm) = nn
nn = nn + ss
Next
For i = 1 To UBound(crr)
crr(i, 4) = d1(crr(i, 3))
Next
d(aa) = crr
Next
With Worksheets("结果")
.UsedRange.Offset(1, 0).Clear
r1 = 2
For Each aa In d.keys
brr = d(aa)
With .Cells(r1, 1)
.Value = aa
.Resize(UBound(brr), 1).Merge
End With
.Cells(r1, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
.Cells(r1, 2).Resize(UBound(brr), UBound(brr, 2)).Sort key1:=.Cells(r1, 5), order1:=xlAscending, Header:=xlNo
With .Cells(r1, 1).Resize(UBound(brr), 1 + UBound(brr, 2))
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
r1 = r1 + UBound(brr)
Next
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
With Worksheets("结果1")
.Cells.Clear
n = 1
For Each aa In d.keys
brr = d(aa)
With .Cells(1, n)
.Value = aa
.Resize(1, 4).Merge
End With
.Cells(2, n).Resize(1, 4) = Array("班级", "姓名", "成绩", "排名")
.Cells(3, n).Resize(UBound(brr), UBound(brr, 2)) = brr
.Cells(3, n).Resize(UBound(brr), UBound(brr, 2)).Sort key1:=.Cells(3, n + 3), order1:=xlAscending, Header:=xlNo
With .Cells(1, n).Resize(2 + UBound(brr), UBound(brr, 2))
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
n = n + 5
Next
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2022-5-20 16:03

详见附件。

opel-wong · 发表于 2022-5-20 16:13

chxw68 发表于 2022-5-20 16:03
详见附件。

先不说结果与效率，，，

光是这114行代码，也要敲好一会儿，，
佩服，学习了！

zpy2 · 发表于 2022-5-20 18:25

select * from 各科成绩前十名中国式品名 limit 3;

cli_one_dim~各科成绩前十名中国式排名~2;

create temp table aa as select 属性学科,姓姓名,班级,数量成绩,dense_rank() over (partition by 属性 order by 数量 desc) 排名 from 各科成绩前十名中国式排名union;

create temp table bb as select * from aa where 排名<=10; select count(*) 行,学科,group_concat(班级),group_concat(姓名),group_concat(成绩),group_concat(排名) from bb group by 学科; select 学科,group_concat(班级||姓名||成绩||排名) 子表 from bb group by 学科;

aman1516 · 发表于 2022-5-20 19:08

数据不大，表格规范，若后继无特殊数据处理，
就用工作表循环排下序吧：

Sub TOP10D()
Dim arr, ar, r, c, i, j, k, m, n
Application.DisplayAlerts = False
With Sheets("成绩")
r = .[A65536].End(xlUp).Row
arr = .Range("A1:K" & r)
ReDim ar(1 To UBound(arr), 1 To 5)
k = 1
ar(k, 1) = "科目": ar(k, 2) = "班级": ar(k, 3) = "姓名": ar(k, 4) = "成绩": ar(k, 5) = "名次"
For c = 3 To UBound(arr, 2)
.Range("A2:K" & r).Sort key1:=.Cells(2, c), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal 'xlAscending 'xlDescending
For i = 2 To 50
If .Cells(i, c) <> .Cells(i - 1, c) Then j = i - 1
If i > 11 And .Cells(i, c) <> .Cells(11, c) Then Exit For
k = k + 1
ar(k, 1) = .Cells(1, c): ar(k, 2) = .Cells(i, 1): ar(k, 3) = .Cells(i, 2): ar(k, 4) = .Cells(i, c): ar(k, 5) = j
Next
Next
.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr '恢复原始数据
End With
With Sheets("结果2")
.Cells.Clear
.Range("A1").Resize(k, UBound(ar, 2)) = ar
m = 2
For n = 2 To k
If .Cells(n, 1) <> .Cells(n + 1, 1) Then
.Range(.Cells(m, 1), .Cells(n, 1)).Merge
m = n + 1
End If
Next
.Range("A1").Resize(k, UBound(ar, 2)).Borders.LineStyle = xlContinuous
Application.DisplayAlerts = True
End With
End Sub

复制代码

aman1516 · 发表于 2022-5-20 19:09

详见附件：

单科前十名.rar (80.91 KB, 下载次数: 18)

准提部林 · 发表于 2022-5-20 19:43

橫向列表//

Xl0000015.rar (42.32 KB, 下载次数: 38)

cui26896 · 发表于 2022-5-20 23:19

对三位老师的代码测了一下用时，准提部林老师的0.2188s ，aman1516老师的0.2656s，chxw68老师的3.8281s

cui26896 · 发表于 2022-5-21 17:02

仔细研究过三位老师的代码，准提部林老师给出的结果是正确的结果。思路也非常好，化繁为简。避开复杂的二维数组排序，变二维为一维排序，这种思路对解决实际问题很有启发。还有变large排序为快速排序，还可以快一点点。

		自动登录	找回密码
密码			免费注册

[求助] 统计每科前十名数据

评分

评分

评分

评分

评分