[已解决]VBA计算人数

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

本帖最后由武林长风于 2014-7-21 11:06 编辑

工作簿里有16个分小学的工作表，还有6个一至六年级汇总表，比如一年级汇总表，是对16个小学一年级的数据按XX小学XX年班汇总的，请用VBA完成各年级汇总工作表里考试人数、计分人数的结果。
1、考试人数：该班成绩单上的人数
2、计分人数：该班成绩单人数的90%，比如某班考试人数为32人，去掉10%=3.2，进一法取值4，计分人数就是28人。
3、公式里涉及工作表标签名的在对应B列单元格里都有，让B列单元格替换工作表标签，下拉即自动查找相应的工作表，不再手动修改公式里的工作表标签。
按钮1是自动生成各年级汇总表里A列数据的。

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

武林长风 · 发表于 2014-7-21 09:02

等您的答案。

grf1973 · 发表于 2014-7-21 11:00

Sub 汇总()
Dim arr, x&, dk, k%
Dim sh As Worksheet
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Worksheets
If Not sh.Name Like "*汇总*" Then
r = sh.[c65536].End(3).Row
arr = sh.Range("a1:e" & r)
For x = 1 To UBound(arr)
If arr(x, 1) Like "*年*" Then bj = arr(x, 1) '班级名
If Len(arr(x, 5)) > 0 And IsNumeric(arr(x, 5)) Then '判断第5列为数值，则累计加1
xkey = sh.Name & bj '字典key为学校+年班
d(xkey) = d(xkey) + 1
End If
Next
End If
Next
For Each sh In Worksheets
If sh.Name Like "*汇总*" Then
r = sh.[c65536].End(3).Row
sh.Range("d2:e" & r).ClearContents
brr = sh.Range("a1:e" & r)
For x = 2 To UBound(brr)
brr(x, 4) = d(brr(x, 1))
brr(x, 5) = brr(x, 4) - Round(brr(x, 4) * 0.1 + 0.49999, 0)
Next
sh.[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End If
Next
End Sub

复制代码

grf1973 · 发表于 2014-7-21 11:01

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

各学校里面的表式有点不一致。可以对照运算结果自己调一下，关键是“*年*班”都要在第1列。

su45 · 发表于 2014-7-21 11:49

咱也写了个：

Sub suhz()
For Each sh In Worksheets
If sh.Name Like "*汇总*" Then
rng = sh.Range("B3", sh.Cells(sh.Cells(sh.Rows.Count, "A").End(3).Row, "C"))
ReDim arr(1 To UBound(rng), 1 To 2)
For i = 1 To UBound(rng)
n = 0
With Sheets(rng(i, 1))
Set d = .Range("A:A").Find(rng(i, 2), , , 1)
If Not d Is Nothing Then
Set s = d.Offset(1, 1).End(4)
arr(i, 1) = s.Offset(, -1)
arr(i, 2) = arr(i, 1) - Application.Ceiling(arr(i, 1) * 0.1, 1)
End If
End With
Next
sh.Range("D3").Resize(UBound(arr), 2) = arr
End If
Next
End Sub

复制代码

VBA成绩单1.zip (396.08 KB, 下载次数: 8)

grf1973 · 发表于 2014-7-22 10:41

重新编了一下代码，各汇总表里的年班自动生成。原来是根据已有的年班汇总的，有疏漏。

Sub 汇总()
Dim arr, x&, dk, k%
Dim sh As Worksheet
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Worksheets
If Not sh.Name Like "*汇总*" Then
r = sh.[c65536].End(3).Row
arr = sh.Range("a1:e" & r)
For x = 1 To UBound(arr)
If arr(x, 1) Like "*年*" Then bj = arr(x, 1) '班级名
If Len(arr(x, 5)) > 0 And IsNumeric(arr(x, 5)) Then '判断第5列为数值，则累计加1
xkey = sh.Name & bj '字典key为学校+年班
d(xkey) = d(xkey) + 1
End If
Next
End If
Next
dk = d.keys: dt = d.items
ReDim crr(1 To d.Count, 1 To 5)
For Each sh In Worksheets
If sh.Name Like "*汇总*" Then
sh.Range("a2:e1000").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)
End If
Next
sh.[a2].Resize(n, 5) = crr
End If
Next
End Sub

复制代码

grf1973 · 发表于 2014-7-22 10:43

请看附件。各汇总表中左侧是自动生成的年班汇总，右侧是原来给定的年班汇总。

武林长风 · 发表于 2014-7-22 12:20

grf1973 发表于 2014-7-22 10:43
请看附件。各汇总表中左侧是自动生成的年班汇总，右侧是原来给定的年班汇总。

谢谢您，真负责任！{:2812:}

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

[已解决]VBA计算人数

评分

评分