初中学生成绩分析

李桥贵

chxw68 发表于 2019-3-19 21:58
你的这个附件跟在另一个贴子里的附件不一样？两个贴子都不是为了工作？

褚老师，把名称命名错，发错，现已更正。原来生成班级表和总分分数段试着用函数
做，但是没有成功。
我才发帖求助。

chxw68

1. Sub dk()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   With Worksheets("成绩")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a3:s" & r)
   
9.     ReDim brr(1 To UBound(arr), 1 To 13 * 3)
   
10.     For j = 4 To 16
    
11.       imax = Application.Max(Application.Index(arr, 0, j))
    
12.       m = 0
    
13.       For i = 2 To UBound(arr)
    
14.         If arr(i, j) = imax Then
    
15.           m = m + 1
    
16.           n = j * 3 - 11
    
17.           brr(m, n) = arr(i, 1)
    
18.           brr(m, n + 1) = arr(i, 3)
    
19.           brr(m, n + 2) = arr(i, j)
    
20.         End If
    
21.       Next
    
22.     Next
    
23.   End With
    
24.   With Worksheets("单科")
    
25.     .UsedRange.Offset(3, 0).Clear
    
26.     .Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
    
27.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
28.     With .Range("a3:am" & r)
    
29.       .Borders.LineStyle = xlContinuous
    
30.       .HorizontalAlignment = xlCenter
    
31.       .VerticalAlignment = xlCenter
    
32.     End With
    
33.     With .Range("a4:am" & r)
    
34.       With .Font
    
35.         .Name = "微软雅黑"
    
36.         .Size = 12
    
37.       End With
    
38.     End With
    
39.     .Rows("4:" & r).RowHeight = 22.5
    
40.   End With
    
41. End Sub
    

复制代码

chxw68

先写个最简单的单科统计代码。

chxw68

1. Sub yx()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("成绩")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a4:s" & r)
    
11.   End With
    
12.   For i = 1 To UBound(arr)
    
13.     If arr(i, 17) > 800 Then
    
14.       If Not d.exists(arr(i, 2)) Then
    
15.         m = 1
    
16.         ReDim brr(1 To 5, 1 To m)
    
17.       Else
    
18.         brr = d(arr(i, 2))
    
19.         m = UBound(brr, 2) + 1
    
20.         ReDim Preserve brr(1 To 5, 1 To m)
    
21.       End If
    
22.       brr(1, m) = arr(i, 1)
    
23.       brr(2, m) = arr(i, 3)
    
24.       brr(3, m) = arr(i, 17)
    
25.       brr(4, m) = arr(i, 18)
    
26.       brr(5, m) = arr(i, 19)
    
27.       d(arr(i, 2)) = brr
    
28.     End If
    
29.   Next
    
30.   With Worksheets("优秀")
    
31.     .UsedRange.Offset(3, 0).ClearContents
    
32.     n = 1
    
33.     For Each aa In d.keys
    
34.       brr = d(aa)
    
35.       ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
36.       For i = 1 To UBound(brr)
    
37.         For j = 1 To UBound(brr, 2)
    
38.           crr(j, i) = brr(i, j)
    
39.         Next
    
40.       Next
    
41.       .Cells(2, n + 2) = aa
    
42.       With .Cells(4, n).Resize(UBound(crr), UBound(crr, 2))
    
43.         .Value = crr
    
44.       End With
    
45.       .Cells(4, n).Resize(UBound(crr), UBound(crr, 2)).Sort key1:=.Cells(4, n + 3), order1:=xlAscending, Header:=xlGuess
    
46.       n = n + 6
    
47.     Next
    
48.   End With
    
49. End Sub
    

复制代码

chxw68

由易到难，又写了优秀的代码。

chxw68

其他的表格设计得很奇怪！有些怎么统计也看不懂。

李桥贵

chxw68 发表于 2019-3-20 10:31
其他的表格设计得很奇怪！有些怎么统计也看不懂。

老师我再修改一下，谢谢您。

李桥贵

老师，我也试着做了一下，能力有限做得不好。做了个利用总成绩表生成班级表，是分两步完成，麻烦您帮忙优化一下代码。
综合成绩分析1.zip (274.23 KB, 下载次数: 18)

2019-3-20 21:00 上传

点击文件名下载附件

chxw68

李桥贵 发表于 2019-3-20 21:00
老师，我也试着做了一下，能力有限做得不好。做了个利用总成绩表生成班级表，是分两步完成，麻烦您帮忙优化 ...

你的统计表很特别！以前从没见过这样统计的，人为的增加了一些麻烦。

李桥贵

chxw68 发表于 2019-3-20 21:11
你的统计表很特别！以前从没见过这样统计的，人为的增加了一些麻烦。

因为是学区的统一要求上报格式。