Question

我之前从未编写过代码，但是对于一个项目，我正在分析幻想篮球统计数据，以确定哪些球队会在比赛中获胜。共有9个统计类别，总共12个团队，并且在1和2队之间的对决中，无论哪个队伍在一个类别中哪个更好，得到1，另一个得到0.领带给予每个.5。总计是相加的，获胜者是拥有更多积分的团队。

我已经编写了一个宏，它将团队1与每个类别的所有其他人进行比较，并相应地为每个类别提供1或0。我在编写循环时遇到问题，然后从第2组开始，并将其与其他所有循环进行比较。我试过围绕另外两个进行for循环，但我似乎无法正确地抵消它或让它工作。任何帮助，将不胜感激。我的代码如下。谢谢！

Sub WhoWins()

    Dim teamAcounter As Integer
    Dim teamBcounter As Integer
    Dim teamAanswercounter As Integer
    Dim teamBanswercounter As Integer
    'these counters keep track of where we are in the stats and answers


    Dim Number1 As Single
    Dim Number2 As Single
    'these are the numbers currently being used to determine a win


    Dim answer1 As Single
    Dim answer2 As Single
    Dim split As Single
    answer1 = 1
    split = 0.5
    answer2 = 0
    'these are used to store a winning/losing/draw value in answers

    teamAanswercounter = teamBcounter + 16
    teamBanswercounter = teamAanswercounter + 1


    Dim columncounter As Integer

    teamAcounter = 3

    For columncounter = 2 to 10


        For teamBcounter = 4 To 14



            Number1 = Cells(teamAcounter, columncounter).Value
            Number2 = Cells(teamBcounter, columncounter).Value

            If Number1 > Number2 Then
                Cells(teamAanswercounter, columncounter).Value = 1 'answer1
                Cells(teamBanswercounter, columncounter).Value = 0 'answer2

            ElseIf Number2 > Number1 Then
                Cells(teamAanswercounter, columncounter).Value = 0 'answer2
                Cells(teamBanswercounter, columncounter).Value = 1 'answer1

             ElseIf Number1 = Number2 Then
                Cells(teamAanswercounter, columncounter).Value = split
                Cells(teamBanswercounter, columncounter).Value = split

            End If

            teamAanswercounter = teamAanswercounter + 3
            teamBanswercounter = teamAanswercounter + 1

        Next teamBcounter
        'teamBcounter = 4
        'teamAcounter = 3
        teamAanswercounter = teamBcounter + 1
        teamBanswercounter = teamAanswercounter + 1


    Next columncounter


End Sub

excel shapshot

Answer 1

这是我对你需要的代码的看法。我评论它是为了帮助理解。

Sub WhoWins()

    Dim ws As Worksheet
    Dim rngTeams As Range
    Dim rngStats As Range
    Dim arrTeams As Variant
    Dim arrStats As Variant
    Dim arrResults() As Variant
    Dim TeamAIndex As Long  'Think of this as the row for Team A
    Dim TeamBIndex As Long  'Think of this as the row for Team B
    Dim StatIndex As Long   'Think of this as the column
    Dim ResultIndex As Long
    Dim NumTeams As Long
    Dim NumStats As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")  'Change sheetname if necessary

    'Get the list of teams
    Set rngTeams = ws.Range("A3", ws.Range("A3").End(xlDown))

    'Get the range of statistics
    Set rngStats = rngTeams.Offset(, 1).Resize(, WorksheetFunction.CountA(ws.Rows(rngTeams.Row)) - 1)

    'Convert the ranges into arrays
    arrTeams = Application.Transpose(rngTeams.Value)
    arrStats = rngStats.Value
    NumTeams = UBound(arrTeams) - LBound(arrTeams) + 1
    NumStats = UBound(arrStats, 2) - LBound(arrStats, 2) + 1

    'Ready the results array
    ReDim arrResults(1 To WorksheetFunction.Combin(NumTeams, 2), 1 To 5)
        'arrResults columns
        '1 = TeamAName
        '2 = TeamAScore
        '3 = TeamBName
        '4 = TeamBScore
        '5 = Winner

    For TeamAIndex = LBound(arrTeams) To NumTeams - 1
        For TeamBIndex = TeamAIndex + 1 To NumTeams
            ResultIndex = ResultIndex + 1
            arrResults(ResultIndex, 1) = arrTeams(TeamAIndex)
            arrResults(ResultIndex, 2) = 0
            arrResults(ResultIndex, 3) = arrTeams(TeamBIndex)
            arrResults(ResultIndex, 4) = 0
            For StatIndex = LBound(arrStats, 2) To UBound(arrStats, 2)
                If arrStats(TeamAIndex, StatIndex) > arrStats(TeamBIndex, StatIndex) Then
                    'Team A wins the stat
                    arrResults(ResultIndex, 2) = arrResults(ResultIndex, 2) + 1
                ElseIf arrStats(TeamBIndex, StatIndex) > arrStats(TeamAIndex, StatIndex) Then
                    'Team B wins the stat
                    arrResults(ResultIndex, 4) = arrResults(ResultIndex, 4) + 1
                Else
                    'Tie
                    arrResults(ResultIndex, 2) = arrResults(ResultIndex, 2) + 0.5
                    arrResults(ResultIndex, 4) = arrResults(ResultIndex, 4) + 0.5
                End If
            Next StatIndex
            If arrResults(ResultIndex, 2) > arrResults(ResultIndex, 4) Then
                'Team A Wins the game
                arrResults(ResultIndex, 5) = arrTeams(TeamAIndex)
            ElseIf arrResults(ResultIndex, 4) > arrResults(ResultIndex, 2) Then
                'Team B Wins the game
                arrResults(ResultIndex, 5) = arrTeams(TeamBIndex)
            Else
                'Tie
                arrResults(ResultIndex, 5) = "Tie"
            End If
        Next TeamBIndex
    Next TeamAIndex

    'Output the results
    With ws.Cells(rngTeams.Row + rngTeams.Rows.Count + 1, "A").Resize(, UBound(arrResults, 2))
        .Value = Array("Team A", "Team A Score", "Team B", "Team B Score", "Winner")    'Column headers for the results
        .Offset(1).Resize(ResultIndex).Value = arrResults  'Results data
    End With

End Sub

Answer 2

重构代码使其更加模块化，并且希望更容易理解。未经测试但应该有效。

Sub WhoWins()

    Dim numberOfTeams As Long

    numberOfTeams = 12

    Dim dataStartOffset As Long

    dataStartOffset = 2

    Dim currentCompareRow As Long

    currentCompareRow = dataStartOffset + numberOfTeams + 2


    Dim teamAcounter As Integer

    For teamAcounter = 1 To numberOfTeams

        Dim teamBcounter As Integer

        'Use if you want dublicate compares: For teamBcounter = 1 To numberOfTeams
        For teamBcounter = teamAcounter + 1 To numberOfTeams
            'Ignore comparing team with itself
            If teamBcounter <> teamAcounter Then
                'Calls the CompareTeams subroutine below and sets teamADataRow in it to the value of dataStartOffset + teamAcounter, sets teamBDataRow in it to dataStartOffset + teamAcounter, ...
                CompareTeams dataStartOffset + teamAcounter, dataStartOffset + teamBcounter, currentCompareRow, currentCompareRow + 1
                'After everything in the CompareTeams subroutine is executed this is executed
                currentCompareRow = currentCompareRow + 3
            End If
        Next teamBcounter
    Next teamAcounter

End Sub


Sub CompareTeams(ByVal teamADataRow As Long, ByVal teamBDataRow As Long, ByVal teamAResultRow As Long, ByVal teamBResultRow As Long)

    Dim Number1 As Single
    Dim Number2 As Single

    Dim columncounter As Long

    For columncounter = 2 To 10

        Number1 = Cells(teamADataRow, columncounter).Value
        Number2 = Cells(teamBDataRow, columncounter).Value

        Cells(teamAResultRow, columncounter).Value = CompareValue(Number1, Number2)
        Cells(teamBResultRow, columncounter).Value = CompareValue(Number2, Number1)

    Next columncounter
End Sub

'the Values in () represent the values that have to given to the function, so if you call CompareValue(1,2) then toCompare becomes 1 and compareWith becomes 2
Function CompareValue(ByVal toCompare, ByVal compareWith) As Long

    If toCompare > compareWith Then
        CompareValue = 1
    ElseIf toCompare < compareWith Then
        CompareValue = 0
    ElseIf toCompare = compareWith Then
        CompareValue = 0.5
    End If

End Function

Answer 3

这个很有趣所以我也抓了一把。我把它分成两个函数：LoadTeamStats和WhoWins，对错误的输入进行了一些基本的安全检查等。大力评论以便轻松跟进：

Option Explicit
Sub DoIt()
    Dim Result As String
    Result = WhoWins("Team 1", "Team 2")
    MsgBox Result & " Wins!"
End Sub

run do it

'compare two teams
Function WhoWins(TeamA As String, TeamB As String) As String
    Dim TeamARange As Range, TeamBRange As Range
    Dim TeamAVar As Variant, TeamBVar As Variant
    Dim Score As Single
    Dim Index As Long

    'safety check, make sure team names are defined
    If TeamA = vbNullString Then
        WhoWins = "Error, Team A Is Blank"
        Exit Function
    End If
    If TeamB = vbNullString Then
        WhoWins = "Error, Team B Is Blank"
        Exit Function
    End If

    'load team stats for comparison
    Set TeamARange = LoadTeamStats(TeamA)
    Set TeamBRange = LoadTeamStats(TeamB)

    'safety check, make sure teams were found
    If TeamARange Is Nothing Then
        WhoWins = "Error, Team A Not Found"
        Exit Function
    End If
    If TeamBRange Is Nothing Then
        WhoWins = "Error, Team B Not Found"
        Exit Function
    End If

    'build variant arrays and do comparison
    TeamAVar = TeamARange.Value
    TeamBVar = TeamBRange.Value
    For Index = LBound(TeamAVar) To UBound(TeamAVar)
        If TeamAVar(Index, 1) > TeamBVar(Index, 1) Then
            Score = Score + 1
        ElseIf TeamAVar(Index, 1) < TeamBVar(Index, 1) Then
            Score = Score - 1
        End If
    Next Index

    'determine the winner
    If Score > 0 Then
        WhoWins = TeamA
    ElseIf Score < 0 Then
        WhoWins = TeamB
    Else
        WhoWins = "No one"
    End If
End Function

'load a team's stats
Function LoadTeamStats(TeamName As String) As Range
    Dim Found As Range
    Dim TargetRow As Long
    Dim Source As Worksheet

    'safety check, make sure TeamName is not blank
    If TeamName = vbNullString Then
        LoadTeamStats = Nothing
        Exit Function
    End If

    'set references and find team
    Set Source = ThisWorkbook.Worksheets("Sheet1")
    Set Found = Source.Cells.Find(TeamName, SearchOrder:=xlByRows, SearchDirection:=xlNext, LookAt:=xlWhole)

    'safety check, make sure the team was found
    If Found Is Nothing Then
        LoadTeamStats = Nothing
        Exit Function
    End If

    'otherwise, team was found and need to load range
    TargetRow = Found.Row
    With Source
        Set LoadTeamStats = .Range(.Cells(TargetRow, 2), .Cells(TargetRow, 10))
    End With
End Function

Answer 4

投入我的两分钱，因为我自己是幻想篮球的粉丝。这是我使用的代码，根据您的个人设置进行调整。

Function GetStats(TeamName As String) As Object

    'This returns a dictionary object.

    Dim WS As Worksheet
    Dim TeamNameRange As Range, TeamNameCell As Range
    Dim TeamNameRow As Long
    Dim StatsRange As Range, StatsCell As Range
    Dim TeamDict As Object

    Set WS = ThisWorkbook.Sheets("Sheet1")
    With WS
        Set TeamNameRange = .Range("A2:A13")
        Set StatsRange = .Range("B1:J1")
    End With
    Set TeamDict = CreateObject("Scripting.Dictionary")

    For Each TeamNameCell In TeamNameRange
        If TeamNameCell.Value = TeamName Then
            TeamNameRow = TeamNameCell.Row
            Exit For
        End If
    Next

    With TeamDict
        For Each StatsCell In StatsRange
            .Add StatsCell.Value, StatsCell.Offset(TeamNameRow - 1, 0).Value
        Next
    End With

    Set GetStats = TeamDict

End Function

Function MatchUp(HomeTeamName As String, AwayTeamName As String) As String

    Dim HomeTeamStats As Object, AwayTeamStats As Object
    Dim HomeTeamScore As Double, AwayTeamScore As Double
    Dim Res As String

    Set HomeTeamStats = GetStats(HomeTeamName)
    Set AwayTeamStats = GetStats(AwayTeamName)

    HomeTeamScore = 0
    AwayTeamScore = 0

    For Each Key In HomeTeamStats.Keys
        If HomeTeamStats(Key) > AwayTeamStats(Key) Then
            HomeTeamScore = HomeTeamScore + 1
        ElseIf HomeTeamStats(Key) < AwayTeamStats(Key) Then
            AwayTeamScore = AwayTeamScore + 1
        ElseIf HomeTeamStats(Key) = AwayTeamStats(Key) Then
            HomeTeamScore = HomeTeamScore + 0.5
            AwayTeamScore = AwayTeamScore + 0.5
        End If
    Next

    Res = HomeTeamScore & " - " & AwayTeamScore
    If HomeTeamScore > AwayTeamScore Then
        Res = "W " & Res & " L"
    ElseIf HomeTeamScore < AwayTeamScore Then
        Res = "L " & Res & " W"
    ElseIf HomeTeamScore = AwayTeamScore Then
        Res = "T " & Res & " T"
    End If

    MatchUp = Res

End Function

Function MatchUpTwo(HomeTeamName As String, AwayTeamName As String) As String

    Dim HomeTeamStats As Object, AwayTeamStats As Object
    Dim HomeTeamScore As Double, AwayTeamScore As Double
    Dim Res As String

    Set HomeTeamStats = GetStats(HomeTeamName)
    Set AwayTeamStats = GetStats(AwayTeamName)

    HomeTeamScore = 0
    AwayTeamScore = 0

    For Each Key In HomeTeamStats.Keys
        If HomeTeamStats(Key) > AwayTeamStats(Key) Then
            HomeTeamScore = HomeTeamScore + 1
        ElseIf HomeTeamStats(Key) < AwayTeamStats(Key) Then
            AwayTeamScore = AwayTeamScore + 1
        ElseIf HomeTeamStats(Key) = AwayTeamStats(Key) Then
            HomeTeamScore = HomeTeamScore + 0.5
            AwayTeamScore = AwayTeamScore + 0.5
        End If
    Next

    If HomeTeamScore > AwayTeamScore Then
        Res = "WIN"
    ElseIf HomeTeamScore < AwayTeamScore Then
        Res = "LOSE"
    ElseIf HomeTeamScore = AwayTeamScore Then
        Res = "TIE"
    End If

    MatchUpTwo = Res

End Function

将上述代码粘贴到常规模块中。您可以将其用作=MatchUp("Team1", "Team2")或=MatchUpTwo("Team1", "Team2")。

格式的公式

MatchUp和MatchUpTwo之间的区别在于后者输出一个单词而不是一个分数。基本上，主队是第一个参数，而客队是后者的论点。如果它输出WIN，那么主队赢了。 LOSE，你明白了。

以上两个变体都使用GetStats函数，该函数创建统计字典。因此，您可以向左侧添加更多统计信息，向下添加更多团队，并且可以正确扩展。

有关如何以表格格式最佳使用的一个很好的应用程序，请参阅以下屏幕截图：

enter image description here

如您所见，我的参考表位于A1。我的上部匹配表使用MatchUp函数，而下面的一个使用MatchUpTwo函数，并附加条件格式。检查公式栏如何设置公式。只需输入并拖动。

似乎Team 1在我的最后吸得最多。 ;）

欢迎并告诉我们这是否有帮助。

VBA循环遍历具有嵌套for循环的列

4 个答案: