[已解决]VBA计算各科总分

武林长风 · 发表于 2014-7-21 12:06

本帖最后由武林长风于 2014-7-23 20:35 编辑

修改一年级汇总里的按钮1达到下列要求：
1、考试人数：该班成绩单上的人数
2、计分人数：该班成绩单人数的90%，比如某班考试人数为32人，去掉10%=3.2，进一法取值去掉4人，计分人数就是28人。
3、公式里涉及工作表标签名的在对应B列单元格里都有，让B列单元格替换工作表标签，下拉即自动查找相应的工作表，不再手动修改公式里的工作表标签。
4、各科总分:比如数学，去掉该科成绩排在后面的10%的学生成绩，如该班32人，计分人数为28人，则总分计算数学科前28人的成绩之和。
其中1、2已通过按钮1完成，您只要修改代码帮我完成一年级汇总表到六年级汇总表就万分感谢了，剩下的表我用函数完成。

新建文件夹.rar (302.77 KB, 下载次数: 25)

gdw831001 · 发表于 2014-7-21 12:35

都6年级了，自己还是在基础表上下功夫吧，不要说这是领导发来的，没必要学。

武林长风 · 发表于 2014-7-21 12:36

gdw831001 发表于 2014-7-21 12:35
都6年级了，自己还是在基础表上下功夫吧，不要说这是领导发来的，没必要学。

6年级是时间的事，无奈1

武林长风 · 发表于 2014-7-21 12:38

gdw831001 发表于 2014-7-21 12:35
都6年级了，自己还是在基础表上下功夫吧，不要说这是领导发来的，没必要学。

和你们年轻人比不了啊~~~

gdw831001 · 发表于 2014-7-21 12:38

武林长风发表于 2014-7-21 12:36
6年级是时间的事，无奈1

把你的基础表搞好，可能直接用透视表就可以解决了

武林长风 · 发表于 2014-7-21 12:40

gdw831001 发表于 2014-7-21 12:38
把你的基础表搞好，可能直接用透视表就可以解决了

版主建议我发到VBA版求助，用VBA吧。

武林长风 · 发表于 2014-7-21 12:53

表格的样式不规范，我也没办法，想做个模板，以后还能用。

武林长风 · 发表于 2014-7-21 14:26

这个问题好难，请版主帮忙做一下吧。

baksy · 发表于 2014-7-21 14:33

本帖最后由 baksy 于 2014-7-21 15:29 编辑

函数解决
1. 辅助列设定：在“张小”工作表的J4单元格复制以下公式
=IF(N(A4)>0,OFFSET(A4,-(A4+1),),"")
复制J4单元格粘贴到整个J列
复制“张小”工作表的J列粘贴到各个学校工作表的J列。
2. 统计表公式
一年级汇总工作表的D3:G3单元格复制以下公式
D3=COUNTIF(INDIRECT(B3&"!J1:J1500"),C3)
E3=INT(D3*0.9)
F3=SUM(LARGE(IF(INDIRECT(B3&"!J1:J1500")=C3,INDIRECT(B3&"!E1:E1500")),ROW(OFFSET(A$1,,,E3))))
G3=SUM(LARGE(IF(INDIRECT(B3&"!J1:J1500")=C3,INDIRECT(B3&"!F1:F1500")),ROW(OFFSET(A$1,,,E3))))
其中F3和G3公式为三键回车( 公式复制后,点一下公式编辑栏的任意位置,先按住 shift、ctrl 两个键,然后敲enter键。)
全部下拉。

*注：部分学校的数据格式需要调整（没必要的空格等）
其他年级的参考一年级统计表。

grf1973 · 发表于 2014-7-22 16:46

Sub 汇总()
Dim arr, x&, dk, k%
Dim sh As Worksheet, xRng As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
For Each sh In Worksheets
If Not sh.Name Like "*汇总*" Then
r = sh.[c65536].End(3).Row
arr = sh.Range("a1:i" & r)
For x = 1 To UBound(arr)
If arr(x, 1) Like "*年*" And InStr(arr(x, 1), "成绩单") = 0 Then bj = arr(x, 1) '班级名
If Len(arr(x, 4)) > 0 And IsNumeric(arr(x, 4)) Then '判断第5列为数值，则累计加1
xkey = sh.Name & bj '字典key为学校+年班
d(xkey) = d(xkey) + 1
End If
Next
For x = 1 To UBound(arr)
If arr(x, 1) Like "*年*" And InStr(arr(x, 1), "成绩单") = 0 Then
bj = arr(x, 1)
xkey = sh.Name & bj '学校+年班
n = d(xkey): m = n - Round(n * 0.1 + 0.49999, 0) '班级的总人数，计分人数
a = x + 2 '分数开始行
ElseIf Len(arr(x, 4)) > 0 And IsNumeric(arr(x, 4)) Then '判断第5列为数值，则累计总分
For j = 5 To 9 '各学科分数所在列
If Len(arr(a - 1, j)) > 0 Then '表示学科非空
Set xRng = sh.Cells(a, j).Resize(n, 1) '该年班、学科所在的区域
kk = xkey & Left(arr(a - 1, j), 2)
fs = Val(arr(x, j))
If fs > 0 Then If Application.WorksheetFunction.Rank(fs, xRng) < m Then d1(kk) = d1(kk) + fs '前m名算总分
End If
Next
End If
Next
End If
Next
dk = d.keys: dt = d.items
ReDim crr(1 To d.Count, 1 To 10)
For Each sh In Worksheets
If sh.Name Like "*汇总*" Then
sh.Range("a3:j1000").ClearContents
n = 0
For i = 0 To UBound(dk)
xkey = dk(i)
If Left(sh.Name, 2) = Mid(xkey, 3, 2) Then
n = n + 1
crr(n, 1) = xkey
crr(n, 2) = Left(xkey, 2)
crr(n, 3) = Mid(xkey, 3)
crr(n, 4) = dt(i)
crr(n, 5) = crr(n, 4) - Round(crr(n, 4) * 0.1 + 0.49999, 0)
For j = 6 To 10
kk = xkey & Left(sh.Cells(2, j), 2)
crr(n, j) = d1(kk)
Next
End If
Next
sh.[a3].Resize(n, 10) = crr
End If
Next
End Sub

复制代码

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

[已解决]VBA计算各科总分

评分