根据学生所选科目求和并排序

huangke008

大家好，现在有个困难向大家求助。

学校要根据学生所选择的课目求和并排序



比如：选物理、化学、生物 的学生就对  语、数、外、物、化、生 求和， 并在所有选择物理、化学、生物的学生中按总分排序
          选物理、化学、地理 的学生就对 语、数、外、物、化、地 求和，  并在所有选择物理、化学、地理的学生中按总分排序



原始数据已上传。

谢谢，麻烦大家了。

3190496160

Sub 计算()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "成绩表为空！": End
    .Range("g2:h" & r) = Empty
    ar = .Range("a1:q" & r)
    For j = 12 To UBound(ar, 2)
        If Trim(ar(1, j)) <> "" Then
            d(Trim(ar(1, j))) = j
        End If
    Next j
    For i = 2 To UBound(ar)
        hj = 0
        If Trim(ar(i, 2)) <> "" Then
            For j = 3 To 5
                lh = d(Trim(ar(i, j)))
                If lh <> "" Then
                    hj = hj + ar(i, lh)
                End If
            Next j
            For j = 9 To 11
                hj = hj + ar(i, j)
            Next j
            ar(i, 7) = hj
            zd = Trim(ar(i, 3)) & "|" & Trim(ar(i, 4)) & "|" & Trim(ar(i, 5))
            dc(zd) = ""
        End If
    Next i
    .Range("a2:q" & r) = Empty
    For Each k In dc.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        For i = 2 To UBound(ar)
            zd = Trim(ar(i, 3)) & "|" & Trim(ar(i, 4)) & "|" & Trim(ar(i, 5))
            If zd = k Then
                n = n + 1
                For j = 1 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
            End If
        Next i
        For i = 1 To n
            For s = i + 1 To n
                If br(i, 7) < br(s, 7) Then
                    For j = 2 To UBound(ar, 2)
                        kk = br(i, j)
                        br(i, j) = br(s, j)
                        br(s, j) = kk
                    Next j
                End If
            Next s
            br(i, 1) = i
            br(i, 8) = i
        Next i
        rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(rs, 1).Resize(n, UBound(br, 2)) = br
    Next k
End With
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

选科.rar (26.98 KB, 下载次数: 18)

2023-3-15 16:06 上传

点击文件名下载附件

剑指E

给个公式简简单单处理下吧，代码要码一大堆：
G2:
=SUM(INDEX(L2:Q2,MATCH(C2:E2,L$1:Q$1,)),I2:K2)
H2:
=COUNTIFS(C:C,C2,D:D,D2,E:E,E2,G:G,">"&G2)+1

excel玉米

总分求和好做，排序有点难

huangke008

3190496160 发表于 2023-3-15 16:06

谢谢，谢谢，解决大问题了。

huangke008

剑指E 发表于 2023-3-15 16:07
给个公式简简单单处理下吧，代码要码一大堆：
G2:
=SUM(INDEX(L2:Q2,MATCH(C2:E2,L$1:Q$1,)),I2:K2)

您好，第一个SUM的公式显示值错误，定位到C2:E2, 是不是我没有复制好

剑指E

huangke008 发表于 2023-3-15 17:05
您好，第一个SUM的公式显示值错误，定位到C2:E2, 是不是我没有复制好

你的版本是不是365？

huangke008

剑指E 发表于 2023-3-15 17:29
你的版本是不是365？

啊，明白了，我的版本太低了，是2013。谢谢啦。

huangke008

excel玉米 发表于 2023-3-15 16:49
总分求和好做，排序有点难

已经很好了，太感谢啦。