對于以下影像：
我有我們測驗之夜的獨特球員名單。我需要一種方法來選擇和展示我們玩的所有游戲中最好的球員。每個游戲都在自己單獨的桌子上。到目前為止，我們只有 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") ' score sheet
Dim dict As Object, key, ar
Set dict = CreateObject("Scripting.Dictionary")
' scan each table
For Each tbl In ws.ListObjects
Set data = tbl.DataBodyRange
For c = 1 To tbl.HeaderRowRange.Columns.Count
' don't count answer and question
If InStr(1, LCase(tbl.HeaderRowRange.Cells(1, c)), "question") = 0 And InStr(1, LCase(tbl.HeaderRowRange.Cells(1, c)), "answer") = 0 Then
' team from header row
team = tbl.HeaderRowRange.Cells(1, c)
qcount = tbl.DataBodyRange.Rows.Count
score = WorksheetFunction.Sum(data.Cells(1, c).Resize(qcount))
' update team members performance
For Each key In Split(team, ", ")
key = Trim(key) ' team members name
If dict.exists(key) Then
ar = dict(key)
ar(0) = ar(0) score
ar(1) = ar(1) qcount
ar(2) = ar(2) 1 ' number of quizes
dict(key) = ar
Else
dict.Add key, Array(score, qcount, 1)
End If
Next
End If
Next
Next
' dump results to another sheet
Set ws = Sheet2 ' wb.sheets("Player Scores")
With ws
.Cells.Clear
.Range("A1:D1") = Array("Player", "Score", "Avg %", "Number of Quiz's Played")
.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) & " out of " & ar(1)
.Cells(r, 3).FormulaR1C1 = "=" & ar(0) & "/" & ar(1)
.Cells(r, 4) = ar(2)
Next
End With
' Sort table
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
' Format headers
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
' Delete existing format conditions
ws.Range("A1:D" & r).FormatConditions.Delete
' Format data
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
' Format Avg
Dim cs As ColorScale
Set cs = Range("C2:C" & r).FormatConditions.AddColorScale(ColorScaleType:=3)
With cs
' the first color is light red
With .ColorScaleCriteria(1)
.FormatColor.Color = RGB(248, 105, 107)
.Type = xlConditionValueNumber
.Value = 0
End With
' the second color is light yellow
With .ColorScaleCriteria(2)
.FormatColor.Color = RGB(255, 235, 132)
.Type = xlConditionValueNumber
.Value = 0.5
End With
' the third color is light green
With .ColorScaleCriteria(3)
.FormatColor.Color = RGB(99, 190, 123)
.Type = xlConditionValueNumber
.Value = 1
End With
End With
End Function
uj5u.com熱心網友回復：
如果我理解你的問題，你需要檢測最后一行中哪個列名的值最大，所以首先你需要一個新行，你可以隱藏包含上面沒有“/16”的總和，并且在單元格中使用（索引和匹配） ＆ 最大限度）
=INDEX("range of players"; MATCH( MAX("range of scores"); "range of scores" ; 0))
你可以用“,”代替“;” 根據您的辦公室號碼和日期設定
uj5u.com熱心網友回復：
使用另一張紙來整理結果并排序以找到最好的。
Option Explicit
Sub LeagueTable()
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") ' score sheet
Dim dict As Object, key, ar
Set dict = CreateObject("Scripting.Dictionary")
' scan each table
For Each tbl In ws.ListObjects
Set data = tbl.DataBodyRange
For c = 1 To tbl.HeaderRowRange.Columns.Count
' team from header row
team = tbl.HeaderRowRange.Cells(1, c)
qcount = tbl.DataBodyRange.Rows.Count
score = WorksheetFunction.Sum(data.Cells(1, c).Resize(qcount))
' update team members performance
For Each key In Split(team, ",")
key = Trim(key) ' team members name
If dict.exists(key) Then
ar = dict(key)
ar(0) = ar(0) score
ar(1) = ar(1) qcount
ar(2) = ar(2) 1 ' number of quizes
dict(key) = ar
Else
dict.Add key, Array(score, qcount, 1)
End If
Next
Next
Next
' dump results to another sheet
Set ws = Sheet2 'wb.sheets("Player Scores")
With ws
.Cells.Clear
.Range("A1:E1") = Array("Player", "Score", "Count", "Avg %", "Quiz Count")
.Range("D:D").NumberFormat = "0%"
r = 1
For Each key In dict
r = r 1
ar = dict(key)
.Cells(r, 1) = key
.Cells(r, 2) = ar(0)
.Cells(r, 3) = ar(1)
.Cells(r, 4).FormulaR1C1 = "=RC[-2]/RC[-1]"
.Cells(r, 5) = ar(2)
Next
End With
' sort table
With ws.Sort
.SortFields.Clear
.SortFields.Add ws.Range("D1"), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
.SetRange ws.Range("A1:E" & r)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ws.Activate
ws.Range("A1").Select
MsgBox "Done"
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/caozuo/341108.html
下一篇：如何復制并找到最后125行？