[已解决]从“总成绩”表中提取各科全级前20名学生成绩信息

fanyixiao123

要求（vba实现）：从“总成绩”表中提取各科（包括“总分”）全级前20名学生成绩信息（包括考号、姓名、班级、班级名次、年级名次）

最佳答案

月排行榜 / 总排行榜

grf1973

2014-12-1 10:13

1. Sub 取前20名()
   
2.     Dim xRng As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     km = Sheet2.[a3]      '科目
   
5.     Set xRng = Sheet1.[a1:m1].Find(km)    '找到科目在总成绩表中的对应列
   
6.     If Not xRng Is Nothing Then
   
7.         c = xRng.Column
   
8.     Else
   
9.         MsgBox "无对应科目，请重新选择"
   
10.         Exit Sub
    
11.     End If
    
12.     With Sheet1
    
13.         maxr = .[a65536].End(3).Row   '总成绩表最大行
    
14.         arr = .Range("a1:m" & maxr)      '总成绩表读入数组
    
15.         ReDim brr(1 To maxr, 1 To 2)       'brr为级次、班次表
    
16.         Set xRng = .Range(.Cells(2, c), .Cells(maxr, c))      '科目列所有成绩列（用于计算级次）
    
17.         For i = 2 To maxr        '字典d保存科目列对应各班的所有成绩（用于计算班次）
    
18.             bj = arr(i, 3)
    
19.             If Not d.exists(bj) Then Set d(bj) = .Cells(i, c) Else Set d(bj) = Union(d(bj), .Cells(i, c))
    
20.         Next
    
21.         For i = 2 To maxr
    
22.             bj = arr(i, 3): cj = arr(i, c)
    
23.             brr(i, 1) = Application.WorksheetFunction.Rank(cj, xRng)          '级次
    
24.             brr(i, 2) = Application.WorksheetFunction.Rank(cj, d(bj))         '班次
    
25.         Next
    
26.         .Range("n1:o" & maxr) = brr        '第14列级次，第15列班次
    
27.         .Range("a2:o" & maxr).Sort key1:=.Cells(2, 14)     '按级次排序
    
28.         crr = .Range("a1:o" & maxr)      '排序后读入数组crr
    
29.         ReDim drr(2 To 21, 1 To 6)      'drr为最终显示结果的数组
    
30.         For i = 2 To 21
    
31.             drr(i, 1) = crr(i, 1): drr(i, 2) = crr(i, 2): drr(i, 3) = crr(i, 3)      '考号、姓名、班级
    
32.             drr(i, 4) = crr(i, c): drr(i, 5) = crr(i, 15): drr(i, 6) = crr(i, 14)      '成绩、班次、级次
    
33.         Next
    
34.         Sheet2.[c3:h22] = drr
    
35.         .UsedRange.ClearContents
    
36.         .Range("a1:m" & maxr) = arr       '总成绩表恢复原序
    
37.     End With
    
38. End Sub
    
39. 
    
40. Private Sub Worksheet_Change(ByVal Target As Range)
    
41.     With Target
    
42.         If .Row < 3 Or .Row > 22 Or .Column > 1 Then Exit Sub
    
43.     End With
    
44.     Call 取前20名
    
45. End Sub
    

复制代码

跳转到最佳答案楼层

1091126096

能技巧不函数，能函数不VBA。这个用排序就可以了，为什么用VBA？

那么的帅

335290-VBA-各科全级前20名.rar (42.17 KB, 下载次数: 66)

2014-11-28 15:03 上传

点击文件名下载附件

fanyixiao123

那么的帅 发表于 2014-11-28 15:03

帅  师傅  ，    这没分科目啊           只有“总分”    看到不到   语文 、  数学    、英语  等等   前20名信息啊

那么的帅

fanyixiao123 发表于 2014-11-28 16:02
帅  师傅  ，    这没分科目啊           只有“总分”    看到不到   语文 、  数学    、英语  等等    ...

只看到一个20名，不知道各科 分表如何显示？

fanyixiao123

那么的帅 发表于 2014-11-28 16:04
只看到一个20名，不知道各科 分表如何显示？

麻烦你了，那就用函数算了

fanyixiao123

1091126096 发表于 2014-11-28 13:49
能技巧不函数，能函数不VBA。这个用排序就可以了，为什么用VBA？

呵呵，很崇拜vba

fanyixiao123

1091126096 发表于 2014-11-28 13:49
能技巧不函数，能函数不VBA。这个用排序就可以了，为什么用VBA？

给我弄个函数的吧，师傅，简单易懂点的

那么的帅

fanyixiao123 发表于 2014-11-28 16:02
帅  师傅  ，    这没分科目啊           只有“总分”    看到不到   语文 、  数学    、英语  等等    ...

335290-VBA-各科全级前20名-1.rar (43.54 KB, 下载次数: 49)

2014-11-28 16:22 上传

点击文件名下载附件

grf1973

是要一张表生成所有科目及总分的前20名吧，原表复制若干次？用函数可能比较难，尤其是班名的确定。