je ne vois pas ces macros 1/2/3/4. Votre fichier, il faut l'utiliser de quelle manière ?
C'est quoi le but ?
Crocrocro est l'auteur, vous avez un lien vers le poste où il vous a donné ce fichier ?
Bonsoir
Eviter si possible que l'équipe qui viens de finir de jouer ne rejoue sur le même terrain
La macro 1 "bouton 1 dans l'exemple affiche les terrains du premier tour"
La macro bouton 2 3 4 (d'où le soucis attribue le dernier terrain libre)
donc terrain d'où viens jouer l'équipe
Le lien
Bonjour
Si des pros des formules ont une solution a mon problème un grand Merci a vous
Dans le fichier ci-joint je recherche
Feuille Terrains G P
Formule pour affecter le terrain (F4-F33) dans le tour suivant (k4-K33) selon le résultat G/P
Feuille Terrains 13<13
Formule pour affecter le terrain (AH4-AH33) dans le tour suivant (AP4-AP33) selon le résultat 13<13
Merci de votre aide
Merci
Boutons dans l'exemple correspond a la macro "Sub AttribuerTerrainsTour(pNoTour As Integer)"
(AttribuerTerrainsTour(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
If DerLig <= PREMLIG Then
' aucun match du tour précédent joué
MsgBox "Aucun Match joué du tour précédent le " & pNoTour & "ème Tour"
Exit Sub
End If
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 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é pour le" & pNoTour & "ème Tour"
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 tour
I = 0
For k = PREMLIG To Derlig2
'If ActiveSheet.Cells(k, ColTourSuiv) = "" And Cells(k, ColJoueSuiv) <> 0 And Cells(k, ColJoueSuiv).Offset(0, 2) <> 0 And UCase(Cells(k, ColJoueSuiv)) <> "X" And UCase(Cells(k, ColJoueSuiv).Offset(0, 2)) <> "X" Then
If ActiveSheet.Cells(k, ColTourSuiv) = "" And Cells(k, ColJoueSuiv) <> 0 And Cells(k, ColJoueSuiv).Offset(0, 2) <> 0 And IsNumeric(Cells(k, ColJoueSuiv)) And IsNumeric(Cells(k, ColJoueSuiv).Offset(0, 2)) Then
I = I + 1
ActiveSheet.Cells(k, ColTourSuiv) = TabTerrain(TabNo(I))
ActiveSheet.Cells(k, ColTourSuiv).Interior.Color = vbWhite ' Fond en cyan pour mise en évidence
End If
Next k
If I = 0 Then
MsgBox "Aucun Match connu pour le " & pNoTour & "ème Tour"
Else
End If
