请各位大师帮忙！有关学生成绩统计问题

nyxmq

太强大了!师傅您真好，不仅技术高，而且特热情，该问题求教了很多人都未能解决，您帮我解决了，您太神奇了，只要能想到，您就能做到，谢谢！

nyxmq

学生成绩分析1.rar (60.2 KB, 下载次数: 16)

2012-7-3 21:41 上传

点击文件名下载附件

学生成绩分析2.rar (55.67 KB, 下载次数: 17)

2012-7-3 21:40 上传

点击文件名下载附件

老师您好！再次谢谢您！我复制一次考试成绩，班级排名后删除后边一部分学生成绩，统计各班剩下的学生的四率一分，和把全部成绩复制进去，设定同样人数统计成绩有一定的误差，而且有些还不小呢，有空麻烦您找找原因，谢谢！
.

mjzxlmg

1、不要改变表格的结构，原来总分之后还有两列，分别班排名、级排名
2、设置工作表中的结构也不要改变，比如科目满分中删除了总分，那么统计总分时就会出错，如三率

nyxmq

mjzxlmg 发表于 2012-7-4 01:37
1、不要改变表格的结构，原来总分之后还有两列，分别班排名、级排名
2、设置工作表中的结构也不要改变，比 ...

感谢帮助,谢谢您！如增加或减少科目可以吗？是不是只要总分在从右数第三列就行？右边没有班名次，校名次，最右边是总分可以吗？感谢您不厌其烦的给我答复，晚上早点休息，别熬的太晚。我今天改了一天试卷，刚上网，给您回复的太晚了。

mjzxlmg

nyxmq 发表于 2012-7-4 21:42
感谢帮助,谢谢您！如增加或减少科目可以吗？是不是只要总分在从右数第三列就行？右边没有班名次，校名次， ...

是的，增加或减少科目均可，但要保证总分在右数第三列。如果没有校名次班名次的话需要修改一下代码。

nyxmq

mjzxlmg 发表于 2012-7-4 22:01
是的，增加或减少科目均可，但要保证总分在右数第三列。如果没有校名次班名次的话需要修改一下代码。

老师您好！如果总分在最后一列是不是把代码改成last_column = .Cells(2, Columns.Count).End(xlToLeft).Column + 1 '总分在倒数第三列-1，若总分在倒数第二列去掉-1，总分在最后列+1.另外如果想把输出结果按学科横向输出，代码应怎样改？谢谢！

nyxmq

老师您好！如果总分在最后一列是不是把代码改成last_column = .Cells(2, Columns.Count).End(xlToLeft).Column + 1 '总分在倒数第三列-1，若总分在倒数第二列去掉-1，总分在最后列+1.另外如果想把输出结果按学科横向输出，代码应怎样改？谢谢！

nyxmq

请帮忙改成横向输出，如附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set dcs = CreateObject("scripting.dictionary")
   
7.   Set djs = CreateObject("scripting.dictionary")
   
8.   With Worksheets("参数设置")
   
9.     arr = .Range("a4:j9")
   
10.     For j = 2 To UBound(arr, 2)
    
11.       Set dcs(arr(1, j)) = CreateObject("scripting.dictionary")
    
12.       For i = 2 To UBound(arr)
    
13.         dcs(arr(1, j))(arr(i, 1)) = arr(i, j)
    
14.       Next
    
15.     Next
    
16.     r = .Range("a12").End(xlDown).Row
    
17.     arr = .Range("a12:k" & r)
    
18.     For i = 2 To UBound(arr)
    
19.       Set djs(arr(i, 1)) = CreateObject("scripting.dictionary")
    
20.       For j = 2 To UBound(arr, 2)
    
21.         djs(arr(i, 1))(arr(1, j)) = arr(i, j)
    
22.       Next
    
23.     Next
    
24.   End With
    
25.   With Worksheets("成绩")
    
26.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
27.     arr = .Range("a2:n" & r)
    
28.     For j = 4 To 12
    
29.       If Not d.exists(arr(1, j)) Then
    
30.         Set d(arr(1, j)) = CreateObject("scripting.dictionary")
    
31.       End If
    
32.       For i = 2 To UBound(arr)
    
33.         If Len(arr(i, j)) <> 0 Then
    
34.           If Not d(arr(1, j)).exists(arr(i, 1)) Then
    
35.             ReDim brr(1 To 16)
    
36.             brr(1) = arr(i, 1)
    
37.             brr(14) = arr(i, j)
    
38.             brr(15) = arr(i, j)
    
39.             If djs.exists(arr(i, 1)) Then
    
40.               If djs(arr(i, 1)).exists(arr(1, j)) Then
    
41.                 brr(16) = djs(arr(i, 1))(arr(1, j))
    
42.               End If
    
43.             End If
    
44.           Else
    
45.             brr = d(arr(1, j))(arr(i, 1))
    
46.           End If
    
47.           brr(2) = brr(2) + 1
    
48.           brr(3) = brr(3) + arr(i, j)
    
49.           If dcs.exists(arr(1, j)) Then
    
50.             If arr(i, j) <= dcs(arr(1, j))("过差") Then
    
51.               brr(4) = brr(4) + 1
    
52.             End If
    
53.             If arr(i, j) >= dcs(arr(1, j))("及格") Then
    
54.               brr(5) = brr(5) + 1
    
55.             End If
    
56.             If arr(i, j) >= dcs(arr(1, j))("优秀") Then
    
57.               brr(6) = brr(6) + 1
    
58.             End If
    
59.             If arr(i, j) >= dcs(arr(1, j))("特优") Then
    
60.               brr(7) = brr(7) + 1
    
61.             End If
    
62.             If arr(i, j) < brr(14) Then
    
63.               brr(14) = arr(i, j)
    
64.             End If
    
65.             If arr(i, j) > brr(15) Then
    
66.               brr(15) = arr(i, j)
    
67.             End If
    
68.           End If
    
69.           d(arr(1, j))(arr(i, 1)) = brr
    
70.         End If
    
71.       Next
    
72.     Next
    
73.   End With
    
74.   With Worksheets("分析2")
    
75.     .UsedRange.offset(1, 0).Clear
    
76.     .Columns("i:l").NumberFormatLocal = "0.00%"
    
77.     For Each aa In d.keys
    
78.       brr = Application.Transpose(Application.Transpose(d(aa).items))
    
79.       For i = 1 To UBound(brr)
    
80.         If Len(brr(i, 2)) <> 0 Then
    
81.           brr(i, 8) = Round(brr(i, 3) / brr(i, 2), 2)
    
82.           For j = 4 To 7
    
83.             brr(i, j + 5) = Round(brr(i, j) / brr(i, 2), 4)
    
84.           Next
    
85.         End If
    
86.         brr(i, 13) = Round(brr(i, 11) * 0.5 + brr(i, 10) * 0.2 + brr(i, 8) * 0.3, 2)
    
87.       Next
    
88.       r = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
    
89.       .Cells(r, 1) = "科目"
    
90.       With .Cells(r, 2)
    
91.         .Value = aa
    
92.         .Resize(1, 15).Merge
    
93.       End With
    
94.       .Cells(r + 1, 1).Resize(1, 16) = Array("班级", "参考人数", "总分", "过差人数", "及格人数", "优秀人数", "特优人数", "平均分", "过差率", "及格率", "优秀率", "特优率", "综合指数", "最低分", "最高分", "任课教师")
    
95.       .Cells(r + 2, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
    
96.       r1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    
97.       .Range(.Cells(r, 1), .Cells(r1, 16)).Borders.LineStyle = xlContinuous
    
98.     Next
    
99.     With .UsedRange
    
100.       .HorizontalAlignment = xlCenter
     
101.       .VerticalAlignment = xlCenter
     
102.     End With
     
103.   End With
     
104.       
     
105. End Sub
     

复制代码

chxw68

详见附件。