[已解决]计算各各班级各学科及格人数和及格率问题

jhhkh

一张全校成绩表，有各班级各学科的成绩，如何根据不同学科的不同及格分数求各班级各学科的及格人数和及格率

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2012-1-31 20:11

搞定了
附件： Book2-sunjing.rar (33.96 KB, 下载次数: 207)

2012-1-31 20:11 上传

点击文件名下载附件

1. Sub 统计()
   
2.     Dim arr1, arr2, arr3, arr4
   
3.     Dim i As Long, n As Long
   
4.     Dim d As New Dictionary
   
5.     arr1 = Range("Q3:AH3")
   
6.     ReDim arr2(1 To UBound(arr1, 2) / 2)
   
7.     ReDim arr3(1 To 10, 1 To UBound(arr1, 2))
   
8.     For i = 1 To UBound(arr1, 2) Step 2
   
9.         n = n + 1
   
10.         arr2(n) = Mid(arr1(1, i), 6, 2)
    
11.     Next i
    
12.     ReDim arr4(0 To UBound(arr2))
    
13.     arr1 = Range("A2:M" & [A65536].End(xlUp).Row)
    
14.     For i = 1 To UBound(arr1)
    
15.         If d.Exists(arr1(i, 2)) Then
    
16.             arr4 = d(arr1(i, 2))
    
17.             arr4(0) = arr4(0) + 1
    
18.             For j = 1 To UBound(arr2)
    
19.                 If arr1(i, j + 4) >= Val(arr2(j)) Then
    
20.                     arr4(j) = arr4(j) + 1
    
21.                 Else
    
22.                     arr4(j) = arr4(j)
    
23.                 End If
    
24.             Next j
    
25.             d(arr1(i, 2)) = arr4
    
26.         Else
    
27.             arr4(0) = 1
    
28.             For j = 1 To UBound(arr2)
    
29.                 If arr1(i, j + 4) >= Val(arr2(j)) Then
    
30.                     arr4(j) = 1
    
31.                 Else
    
32.                     arr4(j) = 0
    
33.                 End If
    
34.             Next j
    
35.             d.Add arr1(i, 2), arr4
    
36.         End If
    
37.     Next i
    
38.     arr1 = d.Keys
    
39.     For i = 0 To UBound(arr1)
    
40.     arr4 = d(arr1(i))
    
41.         For j = 1 To UBound(arr4)
    
42.             arr3(arr1(i), j * 2 - 1) = arr4(j)
    
43.             arr3(arr1(i), j * 2) = Round(arr4(j) / arr4(0) * 100, 2)
    
44.         Next j
    
45.     Next i
    
46.     Range("Q5:AH14").ClearContents
    
47.     Range("Q5").Resize(UBound(arr3), UBound(arr3, 2)) = arr3
    
48. End Sub

复制代码

跳转到最佳答案楼层

sunjing-zxl

应该不难，试试看

hrpotter

函数的 Book2.rar (30.36 KB, 下载次数: 86)

2012-1-31 18:30 上传

点击文件名下载附件

scl5801

不会·····················

sunjing-zxl

搞定了
附件： Book2-sunjing.rar (33.96 KB, 下载次数: 207)

2012-1-31 20:11 上传

点击文件名下载附件

1. Sub 统计()
   
2.     Dim arr1, arr2, arr3, arr4
   
3.     Dim i As Long, n As Long
   
4.     Dim d As New Dictionary
   
5.     arr1 = Range("Q3:AH3")
   
6.     ReDim arr2(1 To UBound(arr1, 2) / 2)
   
7.     ReDim arr3(1 To 10, 1 To UBound(arr1, 2))
   
8.     For i = 1 To UBound(arr1, 2) Step 2
   
9.         n = n + 1
   
10.         arr2(n) = Mid(arr1(1, i), 6, 2)
    
11.     Next i
    
12.     ReDim arr4(0 To UBound(arr2))
    
13.     arr1 = Range("A2:M" & [A65536].End(xlUp).Row)
    
14.     For i = 1 To UBound(arr1)
    
15.         If d.Exists(arr1(i, 2)) Then
    
16.             arr4 = d(arr1(i, 2))
    
17.             arr4(0) = arr4(0) + 1
    
18.             For j = 1 To UBound(arr2)
    
19.                 If arr1(i, j + 4) >= Val(arr2(j)) Then
    
20.                     arr4(j) = arr4(j) + 1
    
21.                 Else
    
22.                     arr4(j) = arr4(j)
    
23.                 End If
    
24.             Next j
    
25.             d(arr1(i, 2)) = arr4
    
26.         Else
    
27.             arr4(0) = 1
    
28.             For j = 1 To UBound(arr2)
    
29.                 If arr1(i, j + 4) >= Val(arr2(j)) Then
    
30.                     arr4(j) = 1
    
31.                 Else
    
32.                     arr4(j) = 0
    
33.                 End If
    
34.             Next j
    
35.             d.Add arr1(i, 2), arr4
    
36.         End If
    
37.     Next i
    
38.     arr1 = d.Keys
    
39.     For i = 0 To UBound(arr1)
    
40.     arr4 = d(arr1(i))
    
41.         For j = 1 To UBound(arr4)
    
42.             arr3(arr1(i), j * 2 - 1) = arr4(j)
    
43.             arr3(arr1(i), j * 2) = Round(arr4(j) / arr4(0) * 100, 2)
    
44.         Next j
    
45.     Next i
    
46.     Range("Q5:AH14").ClearContents
    
47.     Range("Q5").Resize(UBound(arr3), UBound(arr3, 2)) = arr3
    
48. End Sub

复制代码

dyzx

sunjing-zxl 发表于 2012-1-31 20:11
搞定了
附件：

如果我要提取各班总分前10名学生所有成绩放在SHEET2中，代码应该怎样写，多谢。