[已解决]超难的VBA计算成绩

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

本帖最后由武林长风于 2014-8-10 19:38 编辑

要求见附件。

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

武林长风 · 发表于 2014-7-23 21:33

不知道这个成绩单的格式是否符合要求？

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

武林长风发表于 2014-7-23 21:33
不知道这个成绩单的格式是否符合要求？

若函数公式能做出来，也可以。

chinaman_86 · 发表于 2014-7-23 22:14

高！一个成绩统计整出这么多花样来，给大家提供了练习机会，好样的！
{:1112:}

武林长风 · 发表于 2014-7-23 22:17

chinaman_86 发表于 2014-7-23 22:14
高！一个成绩统计整出这么多花样来，给大家提供了练习机会，好样的！

让给位受累了{:1012:}

su45 · 发表于 2014-7-23 23:07

记得上次有帮做过，只是这次格式改了，你最好是把格式确定好，不会浪费别人的时间！

武林长风 · 发表于 2014-7-23 23:17

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

su45 发表于 2014-7-23 23:07
记得上次有帮做过，只是这次格式改了，你最好是把格式确定好，不会浪费别人的时间！

谢谢您的帮助，上次那个附件反应不太好，格式变了，方法也变了吧。

武林长风 · 发表于 2014-7-24 08:16

求助VBA 高手。

grf1973 · 发表于 2014-7-24 11:02

先做部分吧，把年级汇总都做好了，包括总分、均分，排名。
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 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, 2) Like "*小学*" Then
                  bj = arr(x, 2) '学班名
                  d(bj) = d(bj) + 1
            End If
         Next

         For x = 1 To UBound(arr)
            If arr(x, 2) = "学校" Then
                  bj = arr(x + 1, 2) '学班名
                  n = d(bj): m = n - Round(n * 0.1 + 0.49999, 0) '班级的总人数，计分人数
                  a = x + 1    '分数开始行
            ElseIf Len(arr(x, 4)) > 0 And IsNumeric(arr(x, 4)) Then '判断第4列为数值，则累计总分
                  For j = 5 To 9       '各学科分数所在列
                     If Len(arr(a - 1, j)) > 0 Then       '表示学科非空
                        Set xRng = sh.Cells(a, j).Resize(n, 1) '该年班、学科所在的区域
                        kk = bj & 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 13)
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): a = InStr(xkey, "小学")    'Like：张相公小学一年一班
            If Left(sh.Name, 2) = Mid(xkey, a + 2, 2) Then '汇总表前两位年级数和key中“小学”后的两位（年级）数相同
                  n = n + 1
                  crr(n, 1) = xkey
                  crr(n, 2) = Left(xkey, a + 1)
                  crr(n, 3) = Mid(xkey, a + 2)
                  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)
                     crr(n, 11) = crr(n, 11) + crr(n, j) '总分
                  Next
                  If crr(n, 4) > 0 Then crr(n, 12) = crr(n, 11) / crr(n, 4)       '平均分
            End If
         Next
         sh.[a3].Resize(n, 13) = crr
         Set xRng = sh.[L3].Resize(n, 1)
         sh.[M3].Resize(n, 1).Formula = "=rank(R[0]C[-1],R3C12:R" & n + 2 & "C12)"
      End If
Next
End Sub

grf1973 · 发表于 2014-7-24 12:06

关于统计（不含语数）

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 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, 2) Like "*小学*" Then
bj = arr(x, 2) '学班名
d(bj) = d(bj) + 1
End If
Next
For x = 1 To UBound(arr)
If arr(x, 2) = "学校" Then
bj = arr(x + 1, 2) '学班名
n = d(bj): m = n - Round(n * 0.1 + 0.49999, 0) '班级的总人数，计分人数
a = x + 1 '分数开始行
ElseIf Len(arr(x, 4)) > 0 And IsNumeric(arr(x, 4)) Then '判断第4列为数值，则累计总分
For j = 5 To 9 '各学科分数所在列
If Len(arr(a - 1, j)) > 0 Then '表示学科非空
Set xRng = sh.Cells(a, j).Resize(n, 1) '该年班、学科所在的区域
kk = bj & 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
d1k = d1.keys: d1t = d1.items
For Each sh In Worksheets
If sh.Name Like "*统计" Then
arr = sh.[a1:j1000]
ReDim crr(1 To d1.Count, 1 To 6)
For k = 1 To UBound(arr)
If InStr(arr(k, 1), "成绩单") > 0 Then
nj = Left(arr(k, 1), 2): xk = Mid(arr(k, 1), 4, 2)
n = 0
For i = 0 To UBound(d1k)
xkey = d1k(i): a = InStr(xkey, "小学") 'Like：张相公小学一年一班数学
If nj = Mid(xkey, a + 2, 2) And xk = Right(xkey, 2) Then '年级相同，学科相同，则汇总
n = n + 1
crr(n, 1) = n
crr(n, 2) = Left(xkey, a + 1) '学校
crr(n, 3) = Mid(xkey, a + 2, Len(xkey) - Len(crr(n, 2)) - 2)
rs = d(crr(n, 2) & crr(n, 3)) '总人数：d(学校+年班)
crr(n, 4) = rs - Round(rs * 0.1 + 0.49999, 0)
crr(n, 5) = d1(xkey)
If crr(n, 4) > 0 Then crr(n, 6) = crr(n, 5) / crr(n, 4) '平均分
End If
Next
sh.Cells(k + 2, 1).Resize(n, 6) = crr
sh.Cells(k + 2, "G").Resize(n, 1).Formula = "=rank(R[0]C[-1],R" & k + 2 & "C[-1]:R" & k + n + 2 & "C[-1])"
k = k + n
End If
Next
End If
Next
End Sub

复制代码

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

[已解决]超难的VBA计算成绩

评分