请高手帮忙进行成绩统计

mjzxlmg

请高手帮忙做一个简单的成绩统计，具体要求见附件。谢谢！

fyt1987

数据透视表就可以解决为何非要用程序呢？

zhaogang1960

试试
Sub Macro1()
    Dim arr, brr(), d As Object, i&, j&, m&, s$, t$, v, u
    Set d = CreateObject("scripting.dictionary")
    With Sheets("成绩表")
        arr = .Range("a3:n" & .Range("b65536").End(xlUp).Row)
    End With
    ReDim brr(1 To UBound(arr), 1 To 6)
    For j = 5 To UBound(arr, 2)
        v = arr(1, j) * 0.8
        u = arr(1, j) * 0.6
        t = arr(2, j)
        For i = 3 To UBound(arr)
            s = t & arr(i, 2)
            If Not d.Exists(s) Then
                m = m + 1
                d(s) = m
                brr(m, 1) = t
                brr(m, 2) = arr(i, 2)
                If Len(arr(i, j)) Then
                    brr(m, 3) = 1
                    brr(m, 4) = arr(i, j)
                    If arr(i, j) >= v Then brr(m, 6) = 1
                    If arr(i, j) >= u Then brr(m, 5) = 1
                End If
            Else
                If Len(arr(i, j)) Then
                    brr(d(s), 3) = brr(d(s), 3) + 1
                    brr(d(s), 4) = brr(d(s), 4) + arr(i, j)
                    If arr(i, j) >= v Then brr(d(s), 6) = brr(d(s), 6) + 1
                    If arr(i, j) >= u Then brr(d(s), 5) = brr(d(s), 5) + 1
                End If
            End If
        Next
    Next
    Range("C3:H" & Range("c65536").End(xlUp).Row + 3).ClearContents
    Range("C3").Resize(m, 6) = brr
End Sub

mjzxlmg

这是程序的一部分，所以要用VBA。
不会用数组的输入方法，搞不掂，求助。

zhaogang1960

统计成绩.rar (43.28 KB, 下载次数: 84)

2011-4-20 10:43 上传

点击文件名下载附件

mjzxlmg

谢谢zhaogang1960侠圣。很好用。

jhegzwjb2016

zhaogang1960 发表于 2011-4-20 10:43

下载学习，感谢你的辛苦付出！

chxw68

jhegzwjb2016 发表于 2023-7-8 05:43
下载学习，感谢你的辛苦付出！

厉害！12年前的贴子都能翻出来。

于箱长

只要洛阳铲挥得好，没有古董不科考

jhegzwjb2016

chxw68 发表于 2023-7-8 07:57
厉害！12年前的贴子都能翻出来。

向大师您学习，永远在路上，工作需要时，知识才能体现价值！