求计算各校各级各科平均分优秀率及格率的VBA代码

小草看日出 · 发表于 2024-9-19 17:35

求一篇VBA代码，要求如下：

1、根据16个学科的成绩，每科里面有10个学校的成绩，计算出各校各级各科的平均分、及格率、优秀率，及格指的是大于59.5的分数，优秀指的是大于79.5的分数。

2、在计算出的结果中，标出每列中的最大值和最小值，最大值用绿色字体表示，最小值用红色字体表示。

多谢论坛里的大神。

chxw68 · 发表于 2024-9-19 19:01

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim mypath$, myname$
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
mypath = ThisWorkbook.Path & "\16科期考成绩"
myname = Dir(mypath & "*.xlsx")
n = 1
Do While myname <> ""
If myname <> ThisWorkbook.Name Then
bj = Split(myname, "-")(0)
n = n + 1
d1(bj) = n
Set wb = GetObject(mypath & myname)
With wb
With .Worksheets(1)
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 1)).exists(bj) Then
ReDim brr(1 To 4)
Else
brr = d(arr(i, 1))(bj)
End If
If Len(arr(i, c)) <> 0 Then
brr(1) = brr(1) + 1
brr(2) = brr(2) + arr(i, c)
If arr(i, c) >= 80 Then
brr(3) = brr(3) + 1
End If
If arr(i, c) >= 60 Then
brr(4) = brr(4) + 1
End If
End If
d(arr(i, 1))(bj) = brr
Next
End With
.Close False
End With
End If
myname = Dir
Loop
ls = 1 + d1.Count
ReDim crr(1 To d.Count, 1 To ls)
ReDim drr(1 To d.Count, 1 To ls)
ReDim frr(1 To d.Count, 1 To ls)
m = 0
For Each aa In d.keys
m = m + 1
crr(m, 1) = aa
drr(m, 1) = aa
frr(m, 1) = aa
For Each bb In d(aa).keys
brr = d(aa)(bb)
n = d1(bb)
If Len(brr(1)) <> 0 And brr(1) <> 0 Then
crr(m, n) = Application.Round(brr(2) / brr(1), 2)
drr(m, n) = Application.Round(brr(3) / brr(1), 4)
frr(m, n) = Application.Round(brr(4) / brr(1), 4)
End If
Next
Next
With Worksheets("各校各级各科平均分")
.UsedRange.Offset(1, 0).Clear
With .Range("a1")
.UnMerge
.Resize(1, ls).Merge
End With
.Range("a2") = "学校"
.Range("b2").Resize(1, d1.Count) = d1.keys
.Range("a3").Resize(UBound(crr), UBound(crr, 2)) = crr
With .Range("a2").Resize(1 + UBound(crr), UBound(crr, 2))
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
With Worksheets("各校各级各科优秀率")
With .Range("a1")
.UnMerge
.Resize(1, ls).Merge
End With
.UsedRange.Offset(1, 0).Clear
.Range("a2") = "学校"
.Range("b2").Resize(1, d1.Count) = d1.keys
.Range("a3").Resize(UBound(drr), UBound(drr, 2)) = drr
.Range("b3").Resize(UBound(drr), UBound(drr, 2) - 1).NumberFormatLocal = "0.00%"
With .Range("a2").Resize(1 + UBound(drr), UBound(drr, 2))
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
With Worksheets("各校各级各科及格率")
With .Range("a1")
.UnMerge
.Resize(1, ls).Merge
End With
.UsedRange.Offset(1, 0).Clear
.Range("a2") = "学校"
.Range("b2").Resize(1, d1.Count) = d1.keys
.Range("a3").Resize(UBound(frr), UBound(frr, 2)) = frr
.Range("b3").Resize(UBound(frr), UBound(frr, 2) - 1).NumberFormatLocal = "0.00%"
With .Range("a2").Resize(1 + UBound(frr), UBound(frr, 2))
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2024-9-19 19:03

详见附件。

limonet · 发表于 2024-9-19 19:38

好的，上色是你们的强项。

小草看日出 · 发表于 2024-9-20 11:08

本帖最后由小草看日出于 2024-9-20 11:14 编辑

limonet 发表于 2024-9-19 19:38
好的，上色是你们的强项。

谢谢关注。

小草看日出 · 发表于 2024-9-20 11:15

chxw68 发表于 2024-9-19 19:03
详见附件。

感谢褚老师在百忙之中出手相助。我看了，计算准确。但是有两点如果能完善一下就完美了，一是学校和科目的顺序能不能固定一下，A列的学校顺序依次为高新一小、高新二小、高新三小、皇台小学、实验小学、孙庄小学、溪庄小学、张楼小学、星海学校、世纪星小学；第二行的科目，依次为一语、一数、二语、二数、三语、三数、三英、四语、四数、四英、五语、五数、五英、六语、六数、六英，如附件EXCEL表格中的顺序；二是计算结果中每列是最大值用绿色字体表示，最小值用红色字体表示。再次感谢。

chxw68 · 发表于 2024-9-20 11:45

小草看日出发表于 2024-9-20 11:15
感谢褚老师在百忙之中出手相助。我看了，计算准确。但是有两点如果能完善一下就完美了，一是学校和科目 ...

那就学校和科目顺序按照统计表中的[各校各级各科平均分]顺序排列，这样存在的问题就是事先要把该加的学校和科目加上，否则统计不上。

chxw68 · 发表于 2024-9-20 12:50

修改好了。

小草看日出 · 发表于 2024-9-20 17:04

chxw68 发表于 2024-9-20 12:50
修改好了。

修改后达到我想要的结果了，现在已经完美了。帮我解决了大问题，提高了工作效率，省了很多时间。非常感谢。

		自动登录	找回密码
密码			免费注册

[求助] 求计算各校各级各科平均分优秀率及格率的VBA代码

评分

评分

评分

评分