Boucles VBA en boucle avec des boucles imbriquées

Question

Je n'ai jamais écrit de code auparavant, mais pour un projet, j'analyse des statistiques de basket-ball fantastiques afin de déterminer quelles équipes gagneraient en affrontements. Il y a neuf catégories de statistiques, 12 équipes au total, et dans un match entre les équipes 1 et 2, quelle que soit l'équipe est meilleure dans une catégorie obtient un 1, et l'autre obtient un 0. Les cravates donnent chaque .5. Les totaux sont additionnés, et le gagnant est l'équipe avec plus de points.

J'ai écrit une macro qui compare l'équipe 1 à toutes les autres pour chaque catégorie et leur donne un 1 ou un 0 pour chacun en conséquence. J'ai du mal à écrire une boucle qui commence alors avec l'équipe 2 et la compare à toutes les autres. J'ai essayé de placer une boucle autour des deux autres, mais je n'arrive pas à la décaler correctement ou à la faire fonctionner. Toute aide serait appréciée. Mon code est ci-dessous. Merci!

---

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 

---

Answer 1

Voici mon avis sur le code que vous auriez besoin. Je l'ai commenté pour aider à la compréhension.

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

Code refacturé pour le rendre plus modulaire et, espérons-le, plus facile à comprendre. Non testé mais devrait fonctionner.

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

Celui-ci était amusant, j'ai donc pris un crack à lui aussi. Je partage en deux fonctions: LoadTeamStats et WhoWins, avec des contrôles de sécurité de base pour une mauvaise entrée, etc. a commenté très à faire suivant le long facile:

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 

Answer 4

Throwing dans mes deux cents, comme je suis un fan de basket-ball fantastique moi-même. Voici le code que j'utilise, ajusté pour votre configuration personnelle.

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 

Collez le code ci-dessus dans un module standard. Vous pouvez l'utiliser comme formule au format =MatchUp("Team1", "Team2") ou =MatchUpTwo("Team1", "Team2").

La différence entre MatchUp et MatchUpTwo est que ce dernier sort un mot plutôt qu'un score. Fondamentalement, l'équipe à domicile est le premier argument et l'équipe à l'extérieur est le dernier argument. Si le résultat est WIN, l'équipe locale a gagné. LOSE, et vous obtenez le point.

Les deux variantes ci-dessus utilisent toutes deux la fonction GetStats, qui crée un dictionnaire de statistiques. Vous pouvez donc ajouter plus de statistiques à gauche, plus d'équipes vers le bas, et l'échelle sera correcte.

Pour une belle application de la façon dont cela est mieux utilisé sous forme de tableau, voir la capture d'écran suivante:

Comme vous pouvez le voir, ma table de référence est en A1. Ma table de correspondance supérieure utilise la fonction MatchUp, tandis que celle ci-dessous utilise la fonction MatchUpTwo, avec une mise en forme conditionnelle supplémentaire. Vérifiez la barre de formule comment configurer la formule. Il suffit d'entrer et de faire glisser.Il semble que Team 1 suce le plus de mon côté. ;)

Profitez-en et dites-nous si cela aide.