Excel VBA实现多场知识竞赛最佳选手动态统计与排名功能

需求背景 #

现有知识竞赛夜活动的所有唯一参赛选手名单，需要筛选展示所有场次中的最佳选手。每场竞赛数据单独存储为一个表格，目前仅举办了2场，后续会新增更多场次，因此方案需要支持动态扩展。

功能要求 #

实现一个函数，可筛选出效力过得分最高队伍的最佳选手（选手每场可加入不同队伍）：

• 函数需读取所有表格表头，与唯一选手名单匹配，找出所有已举办及未来将举办的场次中，所有获胜/最高得分队伍里都出现过的选手
• 每次新增竞赛场次时，仅需添加对应新表格即可自动纳入统计
• 支持每场竞赛参赛队伍数量不固定的场景

最终实现代码 #

感谢@CDP1802提供的基础实现方案，运行效果完全符合预期，以下为补充了表格美化和颜色标注后的最终可直接使用代码：

Private Sub Worksheet_Activate()
    Call FindHighestPlayer
End Sub

Function FindHighestPlayer()
    Dim wb As Workbook, ws As Worksheet, tbl As ListObject
    Dim r As Long, c As Long, data As Range
    Dim team As String, score As Single, qcount As Long
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1") ' 得分数据存放工作表
    
    Dim dict As Object, key, ar
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历所有表格统计数据
    For Each tbl In ws.ListObjects
        Set data = tbl.DataBodyRange
        For c = 1 To tbl.HeaderRowRange.Columns.Count
            ' 过滤掉问题和答案列，只统计队伍得分
            If InStr(1, LCase(tbl.HeaderRowRange.Cells(1, c)), "question") = 0 And InStr(1, LCase(tbl.HeaderRowRange.Cells(1, c)), "answer") = 0 Then
                ' 从表头读取队伍成员
                team = tbl.HeaderRowRange.Cells(1, c)
                qcount = tbl.DataBodyRange.Rows.Count
                score = WorksheetFunction.Sum(data.Cells(1, c).Resize(qcount))
                
                ' 更新每个选手的得分数据
                For Each key In Split(team, ", ")
                    key = Trim(key) ' 去除选手名前后空格
                    
                    If dict.exists(key) Then
                        ar = dict(key)
                        ar(0) = ar(0) + score
                        ar(1) = ar(1) + qcount
                        ar(2) = ar(2) + 1 ' 选手参与的竞赛场次
                        dict(key) = ar
                    Else
                        dict.Add key, Array(score, qcount, 1)
                    End If
                Next
            End If
        Next
    Next
    
    ' 将统计结果输出到指定工作表
    Set ws = Sheet2 ' 可替换为你需要存放结果的工作表，如wb.sheets("选手得分榜")
    With ws
        .Cells.Clear
        .Range("A1:D1") = Array("选手姓名", "总得分", "得分率", "参与场次")
        .Range("C:C").NumberFormat = "0%"
        r = 1
        For Each key In dict
            r = r + 1
            ar = dict(key)
            .Cells(r, 1) = key
            .Cells(r, 2) = ar(0) & " / " & ar(1)
            .Cells(r, 3).FormulaR1C1 = "=" & ar(0) & "/" & ar(1)
            .Cells(r, 4) = ar(2)
        Next
    End With
    
    ' 按得分率降序排序
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add ws.Range("C1"), SortOn:=xlSortOnValues, _
            Order:=xlDescending, DataOption:=xlSortNormal
        .SetRange ws.Range("A1:D" & r)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ' 表头格式化
    With ws
        .Range("A1:D1").HorizontalAlignment = xlCenter
        .Range("A1:D1").VerticalAlignment = xlBottom
        .Range("A1:D1").Font.FontStyle = "Bold"
        .Range("A1:D1").Font.Size = 15
        .Range("A1:D1").Font.Color = RGB(68, 84, 106)
        .Range("A1:D1").Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Range("A1:D1").Borders(xlEdgeBottom).Weight = xlThick
        .Range("A1:D1").Borders(xlEdgeBottom).Color = RGB(68, 114, 196)
    End With
    
    ' 清除原有条件格式
    ws.Range("A1:D" & r).FormatConditions.Delete
    ' 数据区域格式化
    With ws
        .Range("A1:D" & r).Locked = True
        .Range("B2:B" & r).NumberFormat = "General"
        .Range("B2:B" & r).HorizontalAlignment = xlRight
        .Range("D2:D" & r).HorizontalAlignment = xlCenter
    End With
    
    ' 得分率列添加三色阶条件格式
    Dim cs As ColorScale
    Set cs = Range("C2:C" & r).FormatConditions.AddColorScale(ColorScaleType:=3)
    With cs
        ' 得分率0%对应浅红色
        With .ColorScaleCriteria(1)
            .FormatColor.Color = RGB(248, 105, 107)
            .Type = xlConditionValueNumber
            .Value = 0
        End With
        ' 得分率50%对应浅黄色
        With .ColorScaleCriteria(2)
            .FormatColor.Color = RGB(255, 235, 132)
            .Type = xlConditionValueNumber
            .Value = 0.5
        End With
        ' 得分率100%对应浅绿色
        With .ColorScaleCriteria(3)
            .FormatColor.Color = RGB(99, 190, 123)
            .Type = xlConditionValueNumber
            .Value = 1
        End With
    End With
End Function

内容的提问来源于stack exchange，提问作者Aquaphor