求能计算16个文件里的总人数、平均分、及格率的VBA代码

小草看日出

由于“双减”政策，不允许为各校老师排名次了，但各校又需要了解每个老师的教学大致情况，需要区级教育部门为各校提供各科成绩的总体情况，以便于参考比照。因此需要我们计算出16个学科里面全区的总体总人数、平均分、及格人数（大于等于59.5的人数）、及格率、优秀人数(大于等于79.5的人数)、优秀率。在文件“三率统计表”中，求一篇能达到此目的的VBA代码，谢谢。

3190496160

Sub 三率统计()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
ReDim br(1 To 1000, 1 To 8)
f = Dir(ThisWorkbook.Path & "\16科期考成绩\*.xls*")
Do While f <> ""
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\16科期考成绩\" & f, 0)
    n = n + 1
    br(n, 1) = wb.Worksheets(1).Name
    ar = wb.Worksheets(1).[a1].CurrentRegion
    wb.Close False
    rs = 0: zf = 0: jg = 0: yx = 0
    For i = 2 To UBound(ar)
        If Trim(ar(i, 6)) <> "" Then
            If IsNumeric(ar(i, 6)) Then
                rs = rs + 1
                zf = zf + ar(i, 6)
                If ar(i, 6) > 59.5 Then
                    jg = jg + 1
                End If
                If ar(i, 6) > 79.5 Then
                    yx = yx + 1
                End If
            End If
        End If
    Next i
    br(n, 2) = rs
    br(n, 3) = zf
    br(n, 4) = zf / rs
    br(n, 5) = jg
    br(n, 6) = jg / rs
    br(n, 7) = yx
    br(n, 8) = yx / rs
f = Dir
Loop
With Sheets("三率统计表")
    .[a1].CurrentRegion.Offset(2) = Empty
    .[a3].Resize(n, 8) = br
End With
MsgBox "ok!"
Application.ScreenUpdating = True
               
End Sub

3190496160

Sub 三率统计()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
ReDim br(1 To 1000, 1 To 8)
f = Dir(ThisWorkbook.Path & "\16科期考成绩\*.xls*")
Do While f <> ""
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\16科期考成绩\" & f, 0)
    n = n + 1
    br(n, 1) = Left(wb.Name, 2)
    ar = wb.Worksheets(1).[a1].CurrentRegion
    wb.Close False
    rs = 0: zf = 0: jg = 0: yx = 0
    For i = 2 To UBound(ar)
        If Trim(ar(i, 6)) <> "" Then
            If IsNumeric(ar(i, 6)) Then
                rs = rs + 1
                zf = zf + ar(i, 6)
                If ar(i, 6) > 59.5 Then
                    jg = jg + 1
                End If
                If ar(i, 6) > 79.5 Then
                    yx = yx + 1
                End If
            End If
        End If
    Next i
    br(n, 2) = rs
    br(n, 3) = zf
    br(n, 4) = zf / rs
    br(n, 5) = jg
    br(n, 6) = jg / rs
    br(n, 7) = yx
    br(n, 8) = yx / rs
f = Dir
Loop
With Sheets("三率统计表")
    .[a1].CurrentRegion.Offset(2) = Empty
    .[a3].Resize(n, 8) = br
End With
MsgBox "ok!"
Application.ScreenUpdating = True
               
End Sub

3190496160

各科总体三率统计.rar (727.64 KB, 下载次数: 32)

2021-11-5 14:09 上传

点击文件名下载附件

小草看日出

3190496160 发表于 2021-11-5 14:09

感谢侠圣多次修改帮助。经验证，计算正确。但有一个地方如果能改进一下就更好了——计算结果按照一语、一数、二语、二数、三语、三数、三英、四语、四数、四英、五语、五数、五英、六语、六数、六英顺序显示。其他的，平均分、及格率和优秀率保留两位小数，及格人数设定为大于等于59.5的，优秀人数设定为大于等于59.5的，这些我自己会改。再次感谢出手相助！

xj123321

是这样吗，在3190496160基础上改了下

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr(1 To 1000, 1 To 8)
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim mypath$, myname$
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   mypath = ThisWorkbook.Path & "\16科期考成绩"
   
10.   myname = Dir(mypath & "*.xlsx")
    
11.   m = 0
    
12.   Do While myname <> ""
    
13.     If myname <> ThisWorkbook.Name Then
    
14.       xm = Left(myname, 2)
    
15.       m = m + 1
    
16.       brr(m, 1) = xm
    
17.       Set wb = GetObject(mypath & myname)
    
18.       With wb
    
19.         With .Worksheets(1)
    
20.           r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.           If r > 1 Then
    
22.             arr = .Range("a2:f" & r)
    
23.             For i = 1 To UBound(arr)
    
24.               If Len(arr(i, 6)) <> 0 Then
    
25.                 brr(m, 2) = brr(m, 2) + 1
    
26.                 brr(m, 3) = brr(m, 3) + arr(i, 6)
    
27.                 If arr(i, 6) >= 60 Then
    
28.                   brr(m, 4) = brr(m, 4) + 1
    
29.                 End If
    
30.                 If arr(i, 6) >= 80 Then
    
31.                   brr(m, 6) = brr(m, 6) + 1
    
32.                 End If
    
33.               End If
    
34.             Next
    
35.           End If
    
36.         End With
    
37.         .Close False
    
38.       End With
    
39.     End If
    
40.     myname = Dir
    
41.   Loop
    
42.   If m = 0 Then
    
43.     MsgBox "没有符合条件数据！"
    
44.     Exit Sub
    
45.   End If
    
46.   For i = 1 To m
    
47.     brr(i, 8) = InStr("一二三四五六", Left(brr(i, 1), 1)) * 10 + InStr("语数英", Right(brr(i, 1), 1))
    
48.     If Len(brr(i, 2)) <> 0 And brr(i, 2) <> 0 Then
    
49.       brr(i, 3) = Round(brr(m, 3) / brr(i, 2), 2)
    
50.       brr(i, 5) = Round(brr(i, 4) / brr(i, 2), 4)
    
51.       brr(i, 7) = Round(brr(i, 6) / brr(i, 2), 4)
    
52.     End If
    
53.   Next
    
54. 
    
55.   With Worksheets("三率统计表")
    
56.     .UsedRange.Offset(2, 0).Clear
    
57.     .Range("e:e,g:g").NumberFormatLocal = "0.00%"
    
58.     .Range("a3").Resize(m, UBound(brr, 2)) = brr
    
59.     .Range("a3").Resize(m, UBound(brr, 2)).Sort key1:=.Range("h3"), order1:=xlAscending, Header:=xlNo
    
60.     .Columns(8).Clear
    
61.     With .Range("a1")
    
62.       With .Font
    
63.         .Name = "微软雅黑"
    
64.         .Size = 18
    
65.       End With
    
66.     End With
    
67.     With .Range("a2").Resize(1 + m, 7)
    
68.       .Borders.LineStyle = xlContinuous
    
69.       With .Font
    
70.         .Name = "微软雅黑"
    
71.         .Size = 11
    
72.       End With
    
73.     End With
    
74.     .Rows(1).RowHeight = 30
    
75.     .Rows(2).Resize(1 + m).RowHeight = 20
    
76.     With .UsedRange
    
77.       .HorizontalAlignment = xlCenter
    
78.       .VerticalAlignment = xlCenter
    
79.     End With
    
80.   End With
    
81. End Sub
    

复制代码

chxw68

很长时间没有写成绩分析代码了，练练手。补充：根据楼下网友提醒，修改了其中的错误。

xj123321

chxw68 发表于 2021-11-8 17:34
很长时间没有写成绩分析代码了，练练手。

禇老师出手，格式完美，平均分有问题，    brr(i, 3) = Round(brr(i, m) / brr(i, 2), 2)应为    brr(i, 3) = Round(brr(i, 3) / brr(i, 2), 2)

xiangbaoan

参与一下.zip (21.04 KB, 下载次数: 30)

2021-11-8 18:52 上传

点击文件名下载附件