VBA循环遍历嵌套for循环的列
我以前从来没有写过代码，但是对于一个项目，我正在分析幻想篮球的统计数据，以确定哪支球队能在对决中获胜。 有9个统计类别，总共有12个队伍，而在1队和2队之间的比赛中，无论哪个队伍比较好，一个队伍得到1个，另一个得到0个。 总数是总和，胜者是多点的队伍。
我已经写了一个macros，比较队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 
这是我所需要的代码。 我已经评论它来帮助理解。
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
这一个很有趣，所以我也采取了一个裂缝。 我把它分成两个函数： LoadTeamStats和WhoWins ，对一些不好的input进行一些基本的安全检查等等。
Option Explicit Sub DoIt() Dim Result As String Result = WhoWins("Team 1", "Team 2") MsgBox Result & " Wins!" End Sub
'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
重构代码，使其更模块化，并希望更容易理解。 没有testing，但应该工作。
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
投入我的两分钱，因为我自己是一个幻想篮球迷。 这是我使用的代码，根据您的个人设置进行调整。
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")的格式将其用作公式。
MatchUpTwo和MatchUpTwo的区别在于后者输出一个单词而不是一个分数。 基本上，主队是第一个参数，客队是后一个参数。 如果输出WIN ，那么主队赢了。 LOSE ，你明白了。
上面两个变体都使用GetStats函数，它创build一个统计字典。 因此，您可以向左侧添加更多的统计信息，向下添加更多的统计信息，并且可以正确缩放。
有关表格格式的最佳使用方式，请参阅以下屏幕截图：
正如你所看到的，我的参考表在A1 。 我的上部匹配表使用MatchUp函数，而下面的匹配表使用MatchUpTwo函数，并附加了条件格式。 检查公式栏如何设置公式。 只需input和拖动。
看起来像Team 1最糟糕的是我的结局。 ;）
享受，让我们知道这是否有帮助。