求助做VBA实现学生的成绩分析

gdwl1218 · 发表于 2023-4-17 20:50

本帖最后由 gdwl1218 于 2023-4-18 08:55 编辑

各位老师：

大家好，前两年由褚老师帮忙完成了一个成绩分析文件，特别好，我一直在用！

在此基础上，还想请路过的各位大神，做一下“学科分析2”和“班级总评2”，进而完善我的成绩分析！

“学科分析2”、“班级总评2”与“学科分析1”、“班级总评1”相比，不同点是：

①优秀数、优良数、及格数、低差数的计算方式改变了：

各班优秀数：单科排名占参加考试人数的前10％是“优秀”

各班优良数：单科排名占参加考试人数的前30％是“优良”

各班及格数：单科排名占参加考试人数的前60％是“及格”

各班低差数：单科排名占参加考试人数的后10％是“低差”

例如，全年级有1000名学生参加考试，

语文学科的前10％(排名前100)无论得多少分，成绩都是优秀，数出这些学生中1班的学生数量，就是1班学生语文学科的优秀数；

语文学科的前300名(包括前100名)无论得多少分，成绩都是优良，数出这些学生中1班的学生数量，就是1班学生语文学科的优良数；

…………

②其它项的计算方式和“学科分析1”“班级总评1”一样：

优秀率＝优秀数/参考人数

优良率＝优良数/参考人数

及格率＝及格数/参考人数

低差率＝低差数/参考人数

平均率=单科平均分/单科满分值

综合值=(优秀率+优良率+及格率+平均率-低差率)/3

3190496160 · 发表于 2023-4-18 08:48

或者再请褚兄帮你解决，或者具体描述你的需求，要看懂褚兄的代码再帮你写代码，基本上是不可能的

gdwl1218 · 发表于 2023-4-18 09:05

本帖最后由 gdwl1218 于 2023-4-18 09:22 编辑

3190496160 发表于 2023-4-18 08:48
或者再请褚兄帮你解决，或者具体描述你的需求，要看懂褚兄的代码再帮你写代码，基本上是不可能的

谢谢您的提醒！
我保留褚老师的代码其实是想说明一些需求：
需求①：单击“学科分析”控制按钮→再生成相应的Sheet；单击“还原”控制按钮能删除Sheet；
需求②：表格的样式和各种项目与“学科分析1”“班级总评1”一样
需求③：内部数据的算法：
※参考数：“原始成绩”成绩单中的各班学生数量

※优秀数、优良数、及格数、低差数的计算方式：

单科排名占参加考试人数的前10％是“优秀”；前30％是“优良”；前60％是“及格”；后10％是“低差”

例如，全年级有1000名学生参加考试，

语文学科的前10％(排名前100)无论得多少分，成绩都是优秀，数出这些学生中1班的学生数量，就是1班学生语文学科的优秀数；如果第100名、101名、102名……得分一样，都优秀；

语文学科的前300名(包括前100名)无论得多少分，成绩都是优良，数出这些学生中1班的学生数量，就是1班学生语文学科的优良数；如果第300名、301名、302名……得分一样，都优良；

语文学科的前600名(包括前300名)无论得多少分，成绩都是及格，数出这些学生中1班的学生数量，就是1班学生语文学科的及格数；如果第600名、601名、602名……得分一样，都及格；

语文学科的900名以后无论得多少分，成绩都是低差，数出这些学生中1班的学生数量，就是1班学生语文学科的低差数；如果第900名、901名、902名得分一样，那就是第903名以后的都为低差；

…………

※各种率的计算方式：

优秀率＝优秀数/参考人数

优良率＝优良数/参考人数

及格率＝及格数/参考人数

低差率＝低差数/参考人数

平均率=单科平均分/单科满分值

※综合值=(优秀率+优良率+及格率+平均率-低差率)/3

chxw68 · 发表于 2023-4-18 15:06

修改好了。

gdwl1218 · 发表于 2023-4-18 17:34

chxw68 发表于 2023-4-18 15:06
修改好了。

特别好！
第一次用评分功能，给分少是因为我这里只看到了+2，+1！

gdwl1218 · 发表于 2023-4-18 18:08

本帖最后由 gdwl1218 于 2023-4-18 18:19 编辑

chxw68 发表于 2023-4-18 15:06
修改好了。

老师出现了一点问题：
①在“原始数据”中，没给文综、理综的情况下，要在“成绩汇总”中，根据“政治＋历史＝文综、物理＋化学＝理综”，算出文综、理综成绩，并排名
②在“成绩汇总”中，总分＝除了文综、理综的各项之和
③在“班级总评”中，也是总分＝除了文综、理综的各项之和

chxw68 · 发表于 2023-4-18 19:55

gdwl1218 发表于 2023-4-18 18:08
老师出现了一点问题：
①在“原始数据”中，没给文综、理综的情况下，要在“成绩汇总”中，根据“政治＋ ...

原始成绩手工加入文综、理综和总分成绩吧，不能什么都用代码。

gdwl1218 · 发表于 2023-4-18 20:41

本帖最后由 gdwl1218 于 2023-4-18 20:42 编辑

chxw68 发表于 2023-4-18 19:55
原始成绩手工加入文综、理综和总分成绩吧，不能什么都用代码。

非常感谢您的帮助！
翻看了一下您的帖子，还想请您帮我完成一个需求：
点击“成绩报告单”控制按钮→打开窗体→再由窗体选择“学科”“班级”→点击“确定”按钮，生成需要的“X学科X班”的成绩报告单，样式如下图：

chxw68 · 发表于 2023-4-18 21:40

Sub cjbgd(ByVal xk As String, ByVal nj As String)
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set dcs = CreateObject("scripting.dictionary")
With Worksheets("参数表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For j = 2 To UBound(arr, 2)
Set dcs(arr(1, j)) = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
dcs(arr(1, j))(arr(i, 1)) = arr(i, j)
Next
Next
End With
With Worksheets("原始成绩")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
arr = .Range("a2").Resize(r - 1, c)
End With
ReDim brr(1 To UBound(arr), 1 To 2)
For j = 3 To UBound(arr, 2)
If arr(1, j) = xk Then
j0 = j
End If
Next
For i = 2 To UBound(arr)
If Not d2.exists(arr(i, 2)) Then
Set d2(arr(i, 2)) = CreateObject("scripting.dictionary")
End If
If Len(arr(i, j0)) <> 0 Then
brr(1, 1) = brr(1, 1) + 1
d1(arr(i, j0)) = d1(arr(i, j0)) + 1
d2(arr(i, 2))(arr(i, j0)) = d2(arr(i, 2))(arr(i, j0)) + 1
End If
Next
nn = 1
kk = d1.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d1(mm)
d1(mm) = nn
nn = nn + ss
Next
For Each aa In d2.keys
nn = 1
kk = d2(aa).keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d2(aa)(mm)
d2(aa)(mm) = nn
nn = nn + ss
Next
Next
For i = 2 To UBound(arr)
If Len(arr(i, j0)) <> 0 Then
brr(i, 1) = d1(arr(i, j0))
brr(i, 2) = d2(arr(i, 2))(arr(i, j0))
End If
Next
ReDim drr(1 To 20, 1 To 1)
ReDim crr(1 To 35, 1 To 9)
s = 0
m = 1
n = 1
For i = 2 To UBound(arr)
If arr(i, 2) = nj Then
s = s + 1
crr(m, n) = arr(i, 1)
crr(m, n + 1) = arr(i, j0)
crr(m, n + 2) = brr(i, 1)
crr(m, n + 3) = brr(i, 2)
m = m + 1
If m > 35 Then
m = 1
n = 6
End If
drr(1, 1) = drr(1, 1) + arr(i, j0)
If arr(i, j0) >= dcs(xk)("优秀") Then
drr(4, 1) = drr(4, 1) + 1
End If
If arr(i, j0) >= dcs(xk)("优良") Then
drr(6, 1) = drr(6, 1) + 1
End If
If arr(i, j0) >= dcs(xk)("及格") Then
drr(8, 1) = drr(8, 1) + 1
Else
drr(10, 1) = drr(10, 1) + 1
End If
If brr(i, 1) <= Application.Round(brr(1, 1) * 0.1, 0) Then
drr(13, 1) = drr(13, 1) + 1
End If
If brr(i, 1) <= Application.Round(brr(1, 1) * 0.3, 0) Then
drr(15, 1) = drr(15, 1) + 1
End If
If brr(i, 1) <= Application.Round(brr(1, 1) * 0.6, 0) Then
drr(17, 1) = drr(17, 1) + 1
End If
If brr(i, 1) > Application.Round(brr(1, 1) * 0.9, 0) Then
drr(19, 1) = drr(19, 1) + 1
End If
End If
Next
If s <> 0 Then
drr(1, 1) = Application.Round(drr(1, 1) / s, 2)
drr(5, 1) = Application.Round(drr(4, 1) / s, 4)
drr(7, 1) = Application.Round(drr(6, 1) / s, 4)
drr(9, 1) = Application.Round(drr(8, 1) / s, 4)
drr(11, 1) = Application.Round(drr(10, 1) / s, 4)
drr(14, 1) = Application.Round(drr(13, 1) / s, 4)
drr(16, 1) = Application.Round(drr(15, 1) / s, 4)
drr(18, 1) = Application.Round(drr(17, 1) / s, 4)
drr(20, 1) = Application.Round(drr(19, 1) / s, 4)
End If
On Error Resume Next
Set ws = Worksheets("成绩报告单")
If Err Then
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = "成绩报告单"
End If
On Error GoTo 0
With ws
.Cells.Clear
With .Range("a1")
.Value = Worksheets("原始成绩").Range("a1")
.Resize(1, 12).Merge
With .Font
.Name = "微软雅黑"
.Size = 16
End With
End With
.Range("a2:d2") = Array("姓名", xk, xk & "年名", xk & "班名")
.Range("f2:i2") = Array("姓名", xk, xk & "年名", xk & "班名")
With .Range("a3").Resize(UBound(crr), UBound(crr, 2))
.Value = crr
End With
For Each aa In Array("a2", "f2")
With .Range(aa).Resize(1 + UBound(crr), 4)
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 10
End With
End With
Next
.Range("k2:k4") = Application.Transpose(Array("班级", "参考人数", "学科"))
.Range("l2:l4") = Application.Transpose(Array(nj, s, xk))
With .Range("k2:l4")
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 10
End With
End With
With .Range("k6")
.Resize(1, 2).Merge
.Value = "学科成绩分析"
With .Font
.Name = "微软雅黑"
.Size = 10
End With
End With
.Range("k7:k26") = [{"平均分";"平均率";"";"优秀数";"优秀率";"优良数";"优良率";"及格数";"及格率";"低差数";"低差率";"";"A类生数";"A类比率";"B类生数";"B类生率";"C类生数";"C类生率";"D类生数";"D类生率"}]
.Range("l7").Resize(UBound(drr), UBound(drr, 2)) = drr
For i = 11 To 17 Step 2
.Cells(i, 12).NumberFormatLocal = "0.00%"
Next
For i = 20 To 26 Step 2
.Cells(i, 12).NumberFormatLocal = "0.00%"
Next
With .Range("k7:l26")
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 10
End With
End With
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2023-4-18 21:40

写好了。。

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

[求助] 求助 做VBA实现学生的成绩分析

评分

评分

评分

[求助] 求助做VBA实现学生的成绩分析