Option Explicit
Sub AttribuerTerrains2èmeTour(pNoTour As Integer)
Const PREMLIG = 4
Dim ColTour As Integer ' colonne F (pour 1er Tour)
Dim ColJoue As Integer ' colonne J (Match gagné ou perdu joueur 2 1er Tour)
Dim ColJoueSuiv As Integer ' colonne L (Match gagné ou perdu joueur 1 2ème Tour)
Dim ColTourSuiv As Integer ' colonne K (n° terrain 2ème Tour)
Dim i As Integer, j As Integer, k As Integer
Dim DerLig As Long, Derlig2 As Long
Dim TabTerrain()
Dim NoTerrain As String
Dim TabNo()
Dim alea
Dim Fin As Boolean, Trouve As Boolean
ColTour = 6 + 5 * (pNoTour - 2)
ColJoue = 10 + 5 * (pNoTour - 2)
ColJoueSuiv = 12 + 5 * (pNoTour - 2)
ColTourSuiv = 11 + 5 * (pNoTour - 2)
DerLig = ActiveSheet.Cells(Rows.Count, ColJoue).End(xlUp).Row
Derlig2 = ActiveSheet.Cells(Rows.Count, ColJoueSuiv).End(xlUp).Row
ReDim TabTerrain(1 To DerLig - PREMLIG + 1)
For i = PREMLIG To DerLig
If Not IsEmpty(Cells(i, ColJoue)) Then
'match joué
NoTerrain = Cells(i, ColTour)
' on regarde si le terrain n'est pas déjà attribué pour le 2ème tour
Trouve = False
For k = PREMLIG To Derlig2
If ActiveSheet.Cells(k, ColTourSuiv) = NoTerrain Then
Trouve = True
Exit For
End If
Next k
If Not Trouve Then
j = j + 1
TabTerrain(j) = NoTerrain
End If
End If
Next i
If j = 0 Then
' terrains tous affectés
MsgBox "Aucun Terrain nouvellement attribué"
Exit Sub
End If
ReDim Preserve TabTerrain(1 To j)
ReDim TabNo(1 To UBound(TabTerrain))
k = 0
For i = LBound(TabTerrain) To UBound(TabTerrain)
If Not IsEmpty(TabTerrain(i)) Then
Fin = False
While Not Fin
Randomize
alea = WorksheetFunction.RandBetween(1, UBound(TabTerrain))
Trouve = False
For j = 1 To k
If TabNo(j) = alea Then
Trouve = True
Exit For
End If
Next j
If Not Trouve Then
k = k + 1
TabNo(k) = alea
Fin = True
End If
Wend
End If
Next
'on affecte le tableau du 2ème groupe
i = 0
For k = PREMLIG To Derlig2
'If ActiveSheet.Cells(k, ColTourSuiv) = "" And Not IsEmpty(Cells(k, ColJoue)) Then
If ActiveSheet.Cells(k, ColTourSuiv) = "" And Cells(k, ColJoueSuiv) <> 0 And Cells(k, ColJoueSuiv).Offset(0, 2) <> 0 Then
i = i + 1
ActiveSheet.Cells(k, ColTourSuiv) = TabTerrain(TabNo(i))
End If
Next k
MsgBox "Les Terrains libres sont réaffectés pour le " & pNoTour & "ème Tour"
End Sub
