一分两率计算各班各学科平均分、合格率、优秀率

behan · 发表于 2017-11-2 09:42

请求各位大神，根据“初三级一分两率”、“初三级各班科任”用代码计算出初三级各班科任老师的平均分、合格率、优秀率，例如老师A任教初三（1）、（3）、（5）班语文，计算出这三个班合计的平均分、合格率、优秀率，感谢各位大神，谢谢！

小花鹿 · 发表于 2017-11-2 09:47

要有结果的呈现形式和存放位置................................................................

behan · 发表于 2017-11-2 09:51

我重新上传了新的附件！谢谢

behan · 发表于 2017-11-2 09:53

小花鹿发表于 2017-11-2 09:47
要有结果的呈现形式和存放位置................................................................

我重新上传了新的附件！谢谢

huang1314wei · 发表于 2017-11-2 09:59

楼主这个数据展示模板做的不好，导致数据行列关系没有规律性，想要一键生成，代码会很长，建议你重新整理一下模板再发上来

小花鹿 · 发表于 2017-11-2 10:10

用字典记住各科各班的各种人数和总分，然后再计算每个老师的成绩.............................................

behan · 发表于 2017-11-2 10:18

小花鹿发表于 2017-11-2 10:10
用字典记住各科各班的各种人数和总分，然后再计算每个老师的成绩........................................ ...

我上传了新的！谢谢

behan · 发表于 2017-11-2 10:19

huang1314wei 发表于 2017-11-2 09:59
楼主这个数据展示模板做的不好，导致数据行列关系没有规律性，想要一键生成，代码会很长，建议你重新整理一 ...

我上传新的了，谢谢

chxw68 · 发表于 2017-11-2 11:00

Sub test()
Dim r%, i%
Dim arr, brr, zrr()
Dim d As Object
Dim flg As Boolean
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set djs = 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 djs(arr(1, j)) = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
djs(arr(1, j))(arr(i, 1)) = arr(i, j)
Next
Next
End With
With Worksheets("一分两率")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:a" & r)
flg = False
m = 0
For i = 1 To UBound(arr)
If arr(i, 1) = "班级" Then
ReDim brr(1 To 2)
brr(1) = i - 1
brr(2) = i
flg = True
Else
If flg Then
brr(2) = i
End If
If arr(i, 1) = "合计" Then
m = m + 1
ReDim Preserve zrr(1 To m)
zrr(m) = brr
flg = False
End If
End If
Next
For k = 1 To UBound(zrr)
brr = zrr(k)
arr = .Range(.Cells(brr(1), 1), .Cells(brr(2), 9))
km = Mid(arr(1, 1), 5, 2)
If djs.exists(km) Then
If Not d.exists(km) Then
Set d(km) = CreateObject("scripting.dictionary")
For i = 3 To UBound(arr) - 1
If djs(km).exists(arr(i, 1)) Then
js = djs(km)(arr(i, 1))
If Not d(km).exists(js) Then
ReDim crr(1 To 6)
crr(1) = js
crr(2) = arr(i, 1)
Else
crr = d(km)(js)
crr(2) = crr(2) & "、" & arr(i, 1)
End If
crr(3) = crr(3) + arr(i, 3)
crr(4) = crr(4) + arr(i, 5)
crr(5) = crr(5) + arr(i, 7)
crr(6) = crr(6) + arr(i, 2)
d(km)(js) = crr
End If
Next
End If
End If
Next
End With
With Worksheets("教师一分两率")
.Cells.Clear
.Range("e:f").NumberFormatLocal = "0.00%"
With .Range("a:c,g:g")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
For Each aa In d.keys
r = .Cells(.Rows.Count, 2).End(xlUp).Row
If r > 1 Then
r = r + 2
End If
With .Cells(r, 1).Resize(1, 7)
.Value = Array("科目", "姓名", "班别", "平均分", "全格率", "优秀率", "平均分排名")
.HorizontalAlignment = xlCenter
End With
brr = Application.Transpose(Application.Transpose(d(aa).items))
d1.RemoveAll
For i = 1 To UBound(brr)
brr(i, 3) = Round(brr(i, 3) / brr(i, 6), 2)
brr(i, 4) = Round(brr(i, 4) / brr(i, 6), 4)
brr(i, 5) = Round(brr(i, 5) / brr(i, 6), 4)
d1(brr(i, 3)) = d1(brr(i, 3)) + 1
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 i = 1 To UBound(brr)
brr(i, 6) = d1(brr(i, 3))
Next
.Cells(r + 1, 2).Resize(UBound(brr), UBound(brr, 2)) = brr
With .Cells(r + 1, 1)
.Value = aa
.Resize(UBound(brr), 1).Merge
End With
With .Cells(r, 1).Resize(1 + UBound(brr), 7)
.Borders.LineStyle = xlContinuous
End With
Next
End With
End Sub

复制代码

chxw68 · 发表于 2017-11-2 11:01

把楼主表格结构修改了一下，增加了一个[教师任课表]，代码根据[一分两率]和[教师任课表]自动生成[教师一分两率表]。

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

[求助] 一分两率计算各班各学科平均分、合格率、优秀率

评分

评分