用宏统计考试成绩中的各分数段人数

李桥贵

李桥贵 发表于 2016-8-24 11:34
老师麻烦帮忙一下，能否增加
平均分排名、合格率排名、优秀率排名、平均分年级差、合格率年级差、优秀率 ...

老师麻烦帮忙一下，能否增加
平均分排名、合格率排名、优秀率排名、平均分年级差、合格率年级差、优秀率年级差

李桥贵

李桥贵 发表于 2016-8-24 11:35
老师麻烦帮忙一下，能否增加
平均分排名、合格率排名、优秀率排名、平均分年级差、合格率年级差、优秀率 ...

老师麻烦帮忙一下，能否增加
平均分排名、合格率排名、优秀率排名、平均分年级差、合格率年级差、优秀率年级差

chxw68

只做了第一问和第三问，第二问有些问题不明白没有做。

chxw68

全部做完了。

chxw68

增加了合计项。

lpxkk

好东西收藏了

lzqlaj

chxw68 发表于 2016-8-24 20:59
全部做完了。

收藏了，谢谢分享。

熊文来

mjzxlmg 发表于 2013-12-15 22:34
代码有错，要更正

大侠 能帮我看看我的附件里的问题吗？抽空帮我解决下 好吗？

熊文来

chxw68 发表于 2016-8-25 20:09
增加了合计项。

大侠 抽空您帮我做做好吗？谢谢啦！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, fs(1 To 2)
   
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.     bt = .Range("a1").Resize(1, c)
    
13.     arr = .Range("a2").Resize(r - 1, c)
    
14.   End With
    
15.   For j = 1 To UBound(bt, 2)
    
16.     If InStr("语文数学英语总分", bt(1, j)) <> 0 Then
    
17.       fs(1) = Application.Large(Application.Index(arr, 0, j), 200)
    
18.       fs(2) = Application.Small(Application.Index(arr, 0, j), 200)
    
19.       If bt(1, j) = "总分" Then
    
20.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
21.         ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
    
22.         m = 0
    
23.         n = 0
    
24.         For i = 1 To UBound(arr)
    
25.           If arr(i, j) >= fs(1) Then
    
26.             m = m + 1
    
27.             For k = 1 To UBound(arr, 2)
    
28.               brr(m, k) = arr(i, k)
    
29.             Next
    
30.           End If
    
31.           If arr(i, j) <= fs(2) Then
    
32.             n = n + 1
    
33.             For k = 1 To UBound(arr, 2)
    
34.               crr(n, k) = arr(i, k)
    
35.             Next
    
36.           End If
    
37.         Next
    
38.       Else
    
39.         ReDim brr(1 To UBound(arr), 1 To 8)
    
40.         ReDim crr(1 To UBound(arr), 1 To 8)
    
41.         m = 0
    
42.         n = 0
    
43.         For i = 1 To UBound(arr)
    
44.           If arr(i, j) >= fs(1) Then
    
45.             m = m + 1
    
46.             For k = 1 To 6
    
47.               brr(m, k) = arr(i, k)
    
48.             Next
    
49.             brr(m, 7) = arr(i, j)
    
50.           End If
    
51.           If arr(i, j) <= fs(2) Then
    
52.             n = n + 1
    
53.             For k = 1 To 6
    
54.               crr(n, k) = arr(i, k)
    
55.             Next
    
56.             crr(n, 7) = arr(i, j)
    
57.           End If
    
58.         Next
    
59.       End If
    
60.       If Not d.exists(1) Then
    
61.         Set d(1) = CreateObject("scripting.dictionary")
    
62.       End If
    
63.       If Not d.exists(2) Then
    
64.         Set d(2) = CreateObject("scripting.dictionary")
    
65.       End If
    
66.       d(1)(bt(1, j)) = brr
    
67.       d(2)(bt(1, j)) = crr
    
68.     End If
    
69.   Next
    
70.   For Each aa In d.keys
    
71.     For Each bb In d(aa).keys
    
72.       If bb = "总分" Then
    
73.         wjm = bb & IIf(aa = 1, "前", "倒数") & "200名学生"
    
74.       Else
    
75.         wjm = bb & "单科" & IIf(aa = 1, "前", "倒数") & "200名学生"
    
76.       End If
    
77.       brr = d(aa)(bb)
    
78.       On Error Resume Next
    
79.       Set ws = Worksheets(wjm)
    
80.       If Err Then
    
81.         Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
82.         ws.Name = wjm
    
83.       End If
    
84.       On Error GoTo 0
    
85.       With Worksheets(wjm)
    
86.         .UsedRange.Offset(1, 0).Clear
    
87.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
88.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
89.         c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
90.         If r > 1 Then
    
91.           .Range("a1").Resize(r, c).Sort key1:=.Cells(2, IIf(bb = "总分", 10, 7)), order1:=IIf(aa = 1, xlDescending, xlAscending), Header:=xlYes
    
92.         End If
    
93.       
    
94.       End With
    
95.     Next
    
96.   Next
    
97. End Sub
    

复制代码