这样的高难度成绩分析可能只有求助老师们了

zpy2 · 发表于 2020-7-20 18:21

辛玛发表于 2020-7-20 18:15
谢谢老师指教

select 班级,avg(政治),avg(语文) from 学生成绩明细表 group by 班级

平均分用 avg就行，及格分数线还是60分？

辛玛 · 发表于 2020-7-20 18:48

本帖最后由辛玛于 2020-7-20 19:06 编辑

zpy2 发表于 2020-7-20 18:21
select 班级,avg(政治),avg(语文) from 学生成绩明细表 group by 班级

平均分用 avg就行，及格分数线 ...

谢谢老师。及格分数线不是固定的，是按照与考人数的60%的学生最低分为及格分，优秀分数线，关爱分数线，这些数据chxw68老师已经用代码求出来了。

chxw68 · 发表于 2020-7-20 19:31

三率分析代码

Sub test3()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Call pub
For Each ws In Worksheets(Array("七年级", "八年级", "九年级"))
With ws
Set d(ws.Name) = CreateObject("scripting.dictionary")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
arr = .Range("a2").Resize(r - 1, c)
For i = 2 To UBound(arr)
For j = 5 To UBound(arr, 2)
arr(i, j) = Val(arr(i, j))
Next
Next
d1(ws.Name) = .Range("e2").Resize(1, c - 4)
ls = 2 + (UBound(arr, 2) - 4) * 6
For i = 2 To UBound(arr)
bj = arr(i, 1) & arr(i, 2)
If Not d(ws.Name).exists(bj) Then
ReDim brr(1 To ls)
brr(1) = bj
For j = 5 To UBound(arr, 2)
n = (j - 4) * 6 - 3
If d_js.exists(bj) Then
If d_js(bj).exists(arr(1, j)) Then
brr(n + 4) = d_js(bj)(arr(1, j))
End If
End If
Next
Else
brr = d(ws.Name)(bj)
End If
brr(2) = brr(2) + 1
For j = 5 To UBound(arr, 2)
n = (j - 4) * 6 - 3
If Len(arr(i, j)) <> 0 Then
brr(n) = brr(n) + arr(i, j)
If d_3f.exists(ws.Name) Then
If d_3f(ws.Name).exists(arr(1, j)) Then
If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("及格分") Then
brr(n + 1) = brr(n + 1) + 1
End If
If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("关爱分") Then
brr(n + 2) = brr(n + 2) + 1
End If
End If
End If
End If
d(ws.Name)(bj) = brr
Next
Next
End With
Next
On Error Resume Next
Worksheets("各科三率").Delete
On Error GoTo 0
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = "各科三率"
i1 = 1
For Each aa In d.keys
bt = d1(aa)
With .Cells(i1, 1)
.Value = aa & "成绩分析"
.Resize(1, 2 + UBound(bt, 2) * 6).Merge
With .Font
.Name = "微软雅黑"
.Size = 18
End With
End With
With .Cells(i1 + 1, 1)
.Value = "科目"
.Resize(1, 2).Merge
End With
.Cells(i1 + 2, 1).Resize(1, 2) = Array("学校班级", "与考人数")
n = 3
For j = 1 To UBound(bt, 2)
With .Cells(i1 + 1, n)
.Value = bt(1, j)
.Resize(1, 6).Merge
End With
.Cells(i1 + 2, n).Resize(1, 6) = Array("平均分", "及格率", "关爱率", "三率合计", "科任教师", "排名")
n = n + 6
Next
ReDim crr(1 To d(aa).Count, 1 To 2 + UBound(bt, 2) * 6)
ReDim drr(1 To 2 + UBound(bt, 2) * 6)
drr(1) = "区平均"
m = 0
For Each bb In d(aa).keys
brr = d(aa)(bb)
m = m + 1
For j = 1 To UBound(brr)
crr(m, j) = brr(j)
Next
drr(2) = drr(2) + brr(2)
For k = 3 To UBound(brr) Step 6
For j = 1 To 4
drr(k + j - 1) = drr(k + j - 1) + brr(k + j - 1)
Next
Next
Next
For i = 1 To UBound(crr)
If Len(crr(i, 2)) <> 0 And crr(i, 2) <> 0 Then
For j = 3 To UBound(crr, 2) Step 6
crr(i, j) = Round(crr(i, j) / crr(i, 2), 2)
crr(i, j + 1) = Round(crr(i, j + 1) / crr(i, 2), 4)
crr(i, j + 2) = Round(crr(i, j + 2) / crr(i, 2), 4)
crr(i, j + 3) = Round(crr(i, j) * 0.4 + crr(i, j + 1) * 0.4 * 100 + crr(i, j + 2) * 0.2 * 100, 2)
Next
End If
Next
For j = 3 To UBound(crr, 2) Step 6
d2.RemoveAll
For i = 1 To UBound(crr)
If Len(crr(i, j + 3)) <> 0 Then
d2(crr(i, j + 3)) = d2(crr(i, j + 3)) + 1
End If
Next
nn = 1
kk = d2.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d2(mm)
d2(mm) = nn
nn = nn + ss
Next
For i = 1 To UBound(crr)
If Len(crr(i, j + 3)) <> 0 Then
crr(i, j + 5) = d2(crr(i, j + 3))
End If
Next
Next
If Len(drr(2)) <> 0 And drr(2) <> 0 Then
For j = 3 To UBound(crr, 2) Step 6
drr(j) = Round(drr(j) / drr(2), 2)
drr(j + 1) = Round(drr(j + 1) / drr(2), 4)
drr(j + 2) = Round(drr(j + 2) / drr(2), 4)
drr(j + 3) = Round(drr(j) * 0.4 + drr(j + 1) * 0.4 * 100 + drr(j + 2) * 0.2 * 100, 2)
Next
End If
.Cells(i1 + 3, 1).Resize(1, UBound(drr)) = drr
.Cells(i1 + 4, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
With .Cells(i1 + 1, 1).Resize(2 + 1 + UBound(crr), UBound(crr, 2))
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
i1 = i1 + 2 + UBound(crr) + 2
Next
c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
For j = 3 To c Step 6
.Columns(j + 1).Resize(, 2).NumberFormatLocal = "0.00%"
Next
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.UsedRange.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "各科三率计算完毕！"
End Sub

复制代码

chxw68 · 发表于 2020-7-20 19:32

增加了三分分析的代码。

zpy2 · 发表于 2020-7-20 19:38

zpy2 发表于 2020-7-20 18:21
select 班级,avg(政治),avg(语文) from 学生成绩明细表 group by 班级

平均分用 avg就行，及格分数线 ...

select rowid,姓名,语文,(select count(*)+1 from 学生成绩明细表 as a where cast(a.语文 as long)>cast(b.语文 as long)) 排名 from 学生成绩明细表 b order by cast(语文 as long) desc limit 531,1

这个60%排名的及格分的确难度系数大的，sql不是很方便，一条只能算一个。。。。

辛玛 · 发表于 2020-7-20 19:47

chxw68 发表于 2020-7-20 19:32
增加了三分分析的代码。

谢谢老师，正在测试中

辛玛 · 发表于 2020-7-20 19:48

zpy2 发表于 2020-7-20 19:38
select rowid,姓名,语文,(select count(*)+1 from 学生成绩明细表 as a where cast(a.语文 as long)>cast ...

谢谢老师，辛苦了

辛玛 · 发表于 2020-7-20 20:08

chxw68 发表于 2020-7-20 19:32
增加了三分分析的代码。

完全正确！谢谢chxw68老师无私的帮助

chxw68 · 发表于 2020-7-20 20:46

班级排名统计代码

Sub test4()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Call pub
For Each ws In Worksheets(Array("七年级", "八年级", "九年级"))
With ws
Set d(ws.Name) = CreateObject("scripting.dictionary")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
d1(ws.Name) = .Range("e2").Resize(1, c - 4)
arr = .Range("a2").Resize(r - 1, c + 1)
arr(1, UBound(arr, 2)) = "全科"
For i = 2 To UBound(arr)
For j = 5 To UBound(arr, 2) - 1
arr(i, j) = Val(arr(i, j))
arr(i, UBound(arr, 2)) = arr(i, UBound(arr, 2)) + arr(i, j)
Next
Next
ls = 8
For i = 2 To UBound(arr)
bj = arr(i, 1) & arr(i, 2)
If Not d(ws.Name).exists(bj) Then
ReDim brr(1 To ls)
brr(1) = bj
Else
brr = d(ws.Name)(bj)
End If
brr(2) = brr(2) + 1
jgkm = 0
yxkm = 0
For j = 5 To UBound(arr, 2) - 1
If Len(arr(i, j)) <> 0 Then
brr(3) = brr(3) + arr(i, j)
End If
If d_3f.exists(ws.Name) Then
If d_3f(ws.Name).exists(arr(1, j)) Then
If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("及格分") Then
jgkm = jgkm + 1
End If
End If
If InStr("语文数学英语物理", arr(1, j)) <> 0 Then
If d_3f(ws.Name).exists(arr(1, j)) Then
If arr(i, j) >= d_3f(ws.Name)(arr(1, j))("优秀分") Then
yxkm = yxkm + 1
End If
End If
End If
End If
Next
If jgkm = UBound(arr, 2) - 5 Then
brr(4) = brr(4) + 1
End If
If yxkm = IIf(ws.Name = "七年级", 3, 4) Then
brr(6) = brr(6) + 1
End If
If d_3f.exists(ws.Name) Then
If d_3f(ws.Name).exists("全科") Then
If arr(i, UBound(arr, 2)) >= d_3f(ws.Name)("全科")("关爱分") Then
brr(5) = brr(5) + 1
End If
End If
End If
d(ws.Name)(bj) = brr
Next
End With
Next
On Error Resume Next
Worksheets("班级排名").Delete
On Error GoTo 0
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = "班级排名"
With .Range("a1")
.Value = "班级排名"
.Resize(1, 24).Merge
With .Font
.Name = "微软雅黑"
.Size = 18
End With
End With
n = 1
For Each aa In d.keys
d2.RemoveAll
bt = d1(aa)
With .Cells(2, n)
.Value = aa
.Resize(1, 8).Merge
End With
.Cells(3, n).Resize(1, 8) = Array("学校班级", "与考" & vbLf & "人数", "平均" & vbLf & "分", "全科" & vbLf & "合格率", "关爱" & vbLf & "率", IIf(aa = "七年级", "三科", "四科") & vbLf & "优秀率", "四率" & vbLf & "合计", "排名")
ReDim crr(1 To d(aa).Count, 1 To 8)
ReDim drr(1 To 8)
drr(1) = "区平均"
m = 0
For Each bb In d(aa).keys
brr = d(aa)(bb)
m = m + 1
For j = 1 To UBound(brr)
crr(m, j) = brr(j)
Next
For j = 2 To 6
drr(j) = drr(j) + brr(j)
Next
Next
For i = 1 To UBound(crr)
If Len(crr(i, 2)) <> 0 And crr(i, 2) <> 0 Then
crr(i, 3) = Round(crr(i, 3) / crr(i, 2) / UBound(bt, 2), 2)
crr(i, 4) = Round(crr(i, 4) / crr(i, 2), 4)
crr(i, 5) = Round(crr(i, 5) / crr(i, 2), 4)
crr(i, 6) = Round(crr(i, 6) / crr(i, 2), 4)
crr(i, 7) = Round(crr(i, 3) * 0.3 + crr(i, 4) * 0.3 * 100 + crr(i, 5) * 0.2 * 100 + crr(i, 6) * 0.2 * 100, 2)
d2(crr(i, 7)) = d2(crr(i, 7)) + 1
End If
Next
nn = 1
kk = d2.keys
For k = 0 To UBound(kk)
mm = Application.Large(kk, k + 1)
ss = d2(mm)
d2(mm) = nn
nn = nn + ss
Next
For i = 1 To UBound(crr)
If Len(crr(i, 7)) <> 0 Then
crr(i, 8) = d2(crr(i, 7))
End If
Next
If Len(drr(2)) <> 0 And drr(2) <> 0 Then
drr(3) = Round(drr(3) / drr(2) / UBound(bt, 2), 2)
drr(4) = Round(drr(4) / drr(2), 4)
drr(5) = Round(drr(5) / drr(2), 4)
drr(6) = Round(drr(6) / drr(2), 4)
drr(7) = Round(drr(3) * 0.3 + drr(4) * 0.3 * 100 + drr(5) * 0.2 * 100 + drr(6) * 0.2 * 100, 2)
d2(drr(7)) = d2(drr(7)) + 1
End If
.Cells(4, n).Resize(1, UBound(drr)) = drr
.Cells(5, n).Resize(UBound(crr), UBound(crr, 2)) = crr
With .Cells(2, n).Resize(2 + 1 + UBound(crr), UBound(crr, 2))
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
n = n + 8
Next
c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
For j = 1 To c Step 8
.Columns(j + 3).Resize(, 3).NumberFormatLocal = "0.00%"
Next
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.UsedRange.EntireColumn.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "各科三率计算完毕！"
End Sub

复制代码

chxw68 · 发表于 2020-7-20 20:47

增加了班级排名代码。其他的楼主也没样表，不知道怎么写了。

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

[已解决] 这样的高难度成绩分析可能只有求助老师们了

评分

评分