再次请求大神帮忙做个月考光荣榜

ULINBIN

年级理科（物理线）前二十，文科（历史线）前二十，进步前二十，单科状元

还有就是按班级的各班前十，进步前十，单科状元。
上次请大神帮忙，但还是一头雾水，希望大神能再次帮忙，谢谢！

ULINBIN

我的是wps版本，恳请大神帮忙

3190496160

用vba代码来解决更高效快捷，灵活性强

3190496160

Sub 前20名()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("成绩总表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "成绩总表为空，请先导入数据！": End
    ar = .Range(.Cells(1, 1), .Cells(r, "ap"))
End With
ReDim br_物(1 To UBound(ar), 1 To UBound(ar, 2))
ReDim br_历(1 To UBound(ar), 1 To UBound(ar, 2))
zd_进 = Application.Large(Application.Index(ar, 0, 41), 20)
ReDim brr_进(1 To UBound(ar), 1 To 4)
For i = 2 To UBound(ar)
    If Trim(ar(i, 5)) = "物" Then
        n = n + 1
        For j = 1 To UBound(ar, 2)
            br_物(n, j) = ar(i, j)
        Next j
    ElseIf Trim(ar(i, 5)) = "历" Then
        nn = nn + 1
        For j = 1 To UBound(ar, 2)
            br_历(nn, j) = ar(i, j)
        Next j
    End If
    If Trim(ar(i, 41)) <> "" Then
        If IsNumeric(ar(i, 41)) Then
            If ar(i, 41) >= zd_进 Then
                s = s + 1
                brr_进(s, 1) = ar(i, 2)
                brr_进(s, 2) = ar(i, 3)
                brr_进(s, 3) = ar(i, 37)
                brr_进(s, 4) = ar(i, 41)
            End If
        End If
    End If
Next i
zd_物 = Application.Large(Application.Index(br_物, 0, 37), 20)
ReDim brr_物(1 To n, 1 To 4)
For i = 1 To n
    If Trim(br_物(i, 37)) <> "" Then
        If IsNumeric(br_物(i, 37)) Then
            If br_物(i, 37) >= zd_物 Then
                m = m + 1
                brr_物(m, 1) = br_物(i, 39)
                brr_物(m, 2) = br_物(i, 3)
                brr_物(m, 3) = br_物(i, 2)
                brr_物(m, 4) = br_物(i, 37)
            End If
        End If
    End If
Next i
zd_历 = Application.Large(Application.Index(br_历, 0, 37), 20)
ReDim brr_历(1 To n, 1 To 4)
For i = 1 To nn
    If Trim(br_历(i, 37)) <> "" Then
        If IsNumeric(br_历(i, 37)) Then
            If br_历(i, 37) >= zd_历 Then
                mm = mm + 1
                brr_历(mm, 1) = br_历(i, 39)
                brr_历(mm, 2) = br_历(i, 3)
                brr_历(mm, 3) = br_历(i, 2)
                brr_历(mm, 4) = br_历(i, 37)
            End If
        End If
    End If
Next i
With Sheets("前20名")
    .[a1].CurrentRegion.Offset(2) = Empty
    .[a3].Resize(m, 4) = brr_物
    .[e3].Resize(mm, 4) = brr_历
    .[i3].Resize(s, 4) = brr_进
End With
Application.ScreenUpdating = True
MsgBox zd
End Sub

3190496160

月考光荣榜.rar (276.01 KB, 下载次数: 7)

2022-10-26 15:45 上传

点击文件名下载附件

3190496160

4楼代码有误，以此为准
月考光荣榜.rar (277.6 KB, 下载次数: 11)

2022-10-26 18:24 上传

点击文件名下载附件

Hontyu

................

3190496160

Sub 单科状元()
Dim rng As Range
With Sheets("成绩总表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "成绩总表为空，请先导入数据！": End
    ar = .Range(.Cells(1, 1), .Cells(r, "ap"))
End With
With Sheets("单科状元")
    .UsedRange.Offset(2) = Empty
    yy = .Cells(2, Columns.Count).End(xlToLeft).Column
    rr = .Range(.Cells(1, 1), .Cells(1, yy))
    For s = 1 To UBound(rr, 2) Step 3
        n = 0
        ReDim br(1 To UBound(ar), 1 To 3)
        Set rng = Sheets("成绩总表").Rows(1).Find(rr(1, s), , , , , , 1)
        If Not rng Is Nothing Then
            lh = rng.Column
            zd = Application.Max(Application.Index(ar, 0, lh))
            For i = 2 To UBound(ar)
                If Trim(ar(i, lh)) <> "" Then
                    If IsNumeric(ar(i, lh)) Then
                        If ar(i, lh) = zd Then
                            n = n + 1
                            br(n, 1) = ar(i, 2)
                            br(n, 2) = ar(i, 3)
                            br(n, 3) = ar(i, lh)
                        End If
                    End If
                End If
            Next i
            .Cells(3, s).Resize(n, 3) = br
        End If
    Next s
End With
MsgBox "ok!"
End Sub

3190496160

Sub 班级光荣榜()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
With Sheets("成绩总表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "成绩总表为空，请先导入数据！": End
    ar = .Range(.Cells(1, 1), .Cells(r, "ap"))
End With
ReDim brr_进(1 To UBound(ar), 1 To 4)
With Sheets("班级光荣榜")
    bj = .[d1]
    If bj = "" Then MsgBox "请输入班级": End
    ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) = Trim(bj) Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                arr(n, j) = ar(i, j)
            Next j
        End If
    Next i
    If n = "" Then MsgBox "成绩总表中没有该班级成绩！": End
    zd_进 = Application.Large(Application.Index(arr, 0, 41), 10)
    ReDim brr_总(1 To n, 1 To 3)
    zd_总 = Application.Large(Application.Index(arr, 0, 37), 10)
    For i = 2 To UBound(ar)
        If Trim(arr(i, 41)) <> "" Then
            If IsNumeric(arr(i, 41)) Then
                If arr(i, 41) >= zd_进 Then
                    s = s + 1
                    brr_进(s, 1) = arr(i, 2)
                    brr_进(s, 2) = arr(i, 3)
                    brr_进(s, 3) = arr(i, 37)
                    brr_进(s, 4) = arr(i, 41)
                End If
            End If
        End If
        If Trim(arr(i, 37)) <> "" Then
            If IsNumeric(arr(i, 37)) Then
                If arr(i, 37) >= zd_总 Then
                    m = m + 1
                    brr_总(m, 1) = arr(i, 2)
                    brr_总(m, 2) = arr(i, 3)
                    brr_总(m, 3) = arr(i, 37)
                End If
            End If
        End If
    Next i
    .UsedRange.Offset(4).Clear
    .[a5].Resize(m, 3) = brr_总
    .[e5].Resize(s, 4) = brr_进
    .[a5].Resize(m, 3).Borders.LineStyle = 1
    .[e5].Resize(s, 4).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

月考光荣榜.rar (292.02 KB, 下载次数: 23)

2022-10-27 08:42 上传

点击文件名下载附件