Formule de calcul pour tirage au sort
- Messages
- 9'245
- Excel
- Vista Office 2007FR
- Inscrit
- 08/12/2007
- Emploi
- retraité Sce.Méthodes
Bonjour Fabrice, vba-new, forum,
Cela me rappelle un certain "Concours Pétanque",
A mon avis, tu complique en voulant faire jouer gagnants contre gagnants,
d'ailleurs je ne pense pas cela possible pour la 3ème partie.
voir ce fichier de base:
Bonne journée
Claude
Bonsoir forum, vba-new, Claude,
Pardon de cette réponse tardive
Je n'ai guère le choix, Claude, car ce sont les organisateurs qui décident... Il s'agit là d'une méthode quelque peu différente à celle employée dans ton programme "concours pétanque".tu complique en voulant faire jouer gagnants contre gagnants
Je ne comprends pas bien ta question, vba-new, car en colonne I, il s'agit seulement de la récupération de la valeur en feuille "Résultats". Cela doit revenir au même non ? Essaye de faire le test avec 6 équipes et tu verras tout de suite le problème dès la formule du 2ème tirage.Est-ce que par hasard tu te baserais sur la colonne I de la feuille Tirage pour dire ça ?
Merci encore à tous les 2.
Amicalement.
Fabrice,
Bonjour à tous,
Je n'ai pas excel sous la main mais il me semble que l'ordre des équipes n'est pas la même. Dans la feuille Résultats, on a un ordre chronologique alors que la colonne I de la feuille Tirage n'a pas vraiment d'ordre (il me semble).Fabrice69 a écrit :Je ne comprends pas bien ta question, vba-new, car en colonne I, il s'agit seulement de la récupération de la valeur en feuille "Résultats". Cela doit revenir au même non ? Essaye de faire le test avec 6 équipes et tu verras tout de suite le problème dès la formule du 2ème tirage.
Bonjour à tous, forum, vba-new,
Bon, je refais un point ce soir dans le fichier et tenterai d'être le plus clair possible avec mon exemple reprenant les 6 équipes.
Merci de ta patience.
Amicalement.
Fabrice,
-- Mar Mar 09, 2010 9:43 pm --
Bonsoir à tous, forum,
vba-new, j'ai rentré 12 équipes avec le résultat de la 1ère partie. Tu constateras qu'en feuille "tirage", pour le tirage au sort de la 2ème partie, figure l'équipe 10 en colonne R (gagnants entre-eux) alors qu'elle a perdu. On retrouve d'ailleurs cette équipe en colonne U avec les perdants.
Par contre, on ne trouve nulle part l'équipe 12 qui a disparu du tirage...
Je te joins le fichier pour que tu puisse voir de tes propres yeux (et c'est mieux que des explications alambiquées...).
J'espère que tu pourras faire quelque chose car là, j'avoue que mes connaissances ne suffisent plus.
Merci d'avance.
Amicalement.
Fabrice,
Salut fabrice, forum,
T'as tout à fait raison !Fabrice69 a écrit :...(et c'est mieux que des explications alambiquées...)
Concernant le 2è tirage, est-il indispensable qu'il soit fait à partir de la feuille Résultat ? Si non, il serait en fait plus simple pour moi de faire ce tirage à partir de la colonne I et K de la feuille Tirage. Dans ce cas, voici les nouvelles formules à implémenter :
En O3 :
=DECALER($I3;LIGNE()-3;;;)En R3 :
=SI(ET(MOD(MAX(participants);4)<>0;NBVAL($O$3:O3)=ENT(MAX(participants)/4)+1);K3;DECALER($I3;LIGNE()-2;;;))En U3 :
=SI(NBVAL($K$3:K3)<=NB(K:K)/2;K3;"")En X3 :
=SI(NB(K:K)-LIGNES($1:1)>=NB(K:K)/2;DECALER($K$3;NB(K:K)-LIGNES($1:1);;;);"")ça devrait marcher avec n'importe quel nombre d'équipe (normalement !). De toute façon, s'il y a une erreur, fais signe.
Amicalement
Bonjour Forum, vba-new,
Non ! Pas du tout. Si c'est mieux pour toi de la feuille "Tirage"... Pas de problème.Concernant le 2è tirage, est-il indispensable qu'il soit fait à partir de la feuille Résultat
C'est vraiment super sympa de t'investir autant pour mon projet...
Par contre, je ne pense pas avoir le temps de le tester ce soir et même demain soir. Mais ce week-end, je fais des essais dans tous les sens...
Merci encore à toi.
Amicalement.
Fabrice,
Bonjour forum, fabrice,
Pas de problème pour les tests, tu fais ça quand tu peux.
Par contre, j'ai vu qu'il y avait un petit problème dans la macro du tirage aléatoire. Remplace-la par celle-ci :
Sub tirageAlea()
Dim a As Long, b&, i&, j&, k&, lg&, ld&, temp&, maxi&, cpt&, cpt2&, cpt3&, cpt4&, dercol&, derlign&, derlignTmp&
Dim tabl, test As Boolean, num As Range
If ActiveSheet.Name <> "Tirage" Then MsgBox "Vous n'êtes pas sur la feuille ""Tirage"" !", vbExclamation: Exit Sub
Range("AM3:AN" & [AM65536].End(xlUp).Row).ClearContents 'efface la plage des colonnes AM et AN
'Application.ScreenUpdating = False
i = 3
j = 40
k = 3
derlignTmp = Sheets("Résultats").[bc:bc].Find("*", , xlValues, , xlByRows, xlPrevious).Row
Do While Range("AK" & i) <> " - "
j = IIf(j = 40, 39, 40)
lg = Val(Range("AK" & i))
ld = Right(Range("AK" & i), Len(Range("AK" & i)) - Len(CStr(lg)) - 3)
Set num = Sheets("Résultats").Range("BC10:BC" & derlignTmp).Find(lg, LookIn:=xlValues)
If num.Offset(, 5) = "oui" Then
Cells(k, j) = lg
Else
Cells(k, j) = ld
End If
k = IIf(j = 39, k, k + 1)
i = i + 1
Loop
derlignTmp = [AM65536].End(xlUp).Row + 1
maxi = Application.WorksheetFunction.Max(Sheets("Inscriptions").[C5:C132].Value)
'dimension = Application.WorksheetFunction.Fact(maxi) / Application.WorksheetFunction.Fact(maxi - 2) / 2
ReDim tabl(1 To maxi, 1 To 2)
For i = 3 To [c:c].Find("*", , xlValues, , xlByRows, xlPrevious).Row
tabl(i - 2, 1) = Range("C" & i).Value
tabl(i - 2, 2) = Range("F" & i).Value
cpt = cpt + 1
Next i
cpt2 = cpt
For i = 3 To [o:o].Find("*", , xlValues, , xlByRows, xlPrevious).Row
tabl(i + cpt - 2, 1) = Range("O" & i).Value
tabl(i + cpt - 2, 2) = Range("R" & i).Value
cpt2 = cpt2 + 1
Next i
cpt3 = cpt2
For i = 3 To [u:u].Find("*", , xlValues, , xlByRows, xlPrevious).Row
tabl(i + cpt2 - 2, 1) = Range("U" & i).Value
tabl(i + cpt2 - 2, 2) = Range("X" & i).Value
cpt3 = cpt3 + 1
cpt4 = cpt4 + 1
Next i
temp = cpt4
tirage:
If test Then Range("AM" & derlignTmp & ":AN" & [AM65536].End(xlUp).Row).ClearContents 'efface la plage des colonnes AM et AN
cpt4 = temp / 2
dercol = [AM65536].Column
Do While cpt4 < cpt3 / 2
recommence:
test = False
If Cells(Range("AM65536").End(xlUp).Row, dercol) <> "" And _
Cells(Range("AM65536").End(xlUp).Row, dercol + 1) = "" Then
a = Cells(Range("AM65536").End(xlUp).Row, dercol)
Else
a = [int(max(participants)*rand()+1)]
Do While test = False
For i = 3 To [AM65536].End(xlUp).Row
For j = dercol To dercol + 1
If a = Cells(i, j) Then test = True
If test Then Exit For
Next j
If test Then Exit For
Next i
If test = False Then
Exit Do
Else
test = False
a = [int(max(participants)*rand()+1)]
End If
Loop
End If
b = [int(max(participants)*rand()+1)]
Do While test = False
For i = 3 To [AM65536].End(xlUp).Row
For j = dercol To dercol + 1
If b = Cells(i, j) Or b = a Then test = True
If test Then Exit For
Next j
If test Then Exit For
Next i
If test = False Then
Exit Do
Else
test = False
b = [int(max(participants)*rand()+1)]
End If
Loop
For i = 1 To cpt3
If a = tabl(i, 1) And b = tabl(i, 2) Or _
a = tabl(i, 2) And b = tabl(i, 1) Then test = True
If test Then Exit For
Next i
If test And Cells(Range("AM65536").End(xlUp).Row, dercol) <> "" And _
Cells(Range("AM65536").End(xlUp).Row, dercol + 1) <> "" And cpt4 = cpt3 / 2 - 1 Then GoTo tirage
If test Then GoTo recommence
cpt4 = cpt4 + 1
derlign = Range("AM65536").End(xlUp).Row + 1
If Cells(derlign - 1, dercol) <> "" And _
Cells(derlign - 1, dercol + 1) = "" Then
Cells(derlign - 1, dercol + 1) = b
Else
Cells(derlign, dercol) = a: Cells(derlign, dercol + 1) = b
End If
Loop
a = -1
b = -1
For k = 1 To cpt3
For i = 3 To [AM65536].End(xlUp).Row
For j = dercol To dercol + 1
If k = Cells(i, j) Then test = True
If test Then Exit For
Next j
If test Then Exit For
Next i
If test = False Then
Select Case a
Case Is < 0
a = k
Case Else
b = k
End Select
End If
test = False
If b > 0 Then Exit For
Next k
For i = 1 To cpt3
If a = tabl(i, 1) And b = tabl(i, 2) Or _
a = tabl(i, 2) And b = tabl(i, 1) Then test = True
If test Then Exit For
Next i
If test Then
GoTo tirage
ElseIf test = False And a > 0 And b > 0 Then
Cells(derlign + 1, dercol) = a: Cells(derlign + 1, dercol + 1) = b
End If
End SubBonjour à tous, Forum, vba-new,
J'ai rentré les résultats de 26 équipes et les formules de calcul pour le 2e tirage ont l'air de bien fonctionner.
Par contre, après avoir lancé la macro, je constate que le 3e tirage ne tient pas compte du nombre de parties gagnées.
En effet, en priorité, ce sont les gagnants des 2 premières parties qui doivent se rencontrer entre-eux et avec mon exemple de 26 équipes, ce n'est pas le cas...
vba-new, je joins mon fichier exemple pour que tu puisses constater le problème du 3e tirage.
Tu as fait du super boulot dans ce projet et je ne sais pas comment te remercier pour ta disponibilité...
Encore merci et bonne soirée.
Amicalement.
Fabrice,
Bonjour à tous, salut fabrice,
Après quelques tests, il faut changer une toute petite ligne. Vers le début de la macro, remplace la ligne :
If num.Offset(, 5) = "oui" Thenpar
If num.Offset(, 5) = "OUI" ThenJe pensais qu'il n'y avait pas de différence
Le tirage de la 3è partie ne tient pas compte de l'ordre que l'on trouve en colonne AC, AE et AG de la feuille Tirage, mais le tirage tire bien les gagnants des 2 premières parties en priorité.
Quelqu'un n'a-t-il pas dit que notre seule récompense est un merci ?Fabrice69 a écrit :Tu as fait du super boulot dans ce projet et je ne sais pas comment te remercier pour ta disponibilité...
Si tu rencontres des problèmes, reviens !
A +.
Bonjour à tous, vba-new,
Alors là ! Chapeau bas ! Un grand bravo à toi vba-new pour le programme qui fonctionne à merveille, tout du moins avec mon exemple de 26 équipes...
Si tu le permets, je vais faire d'autres tests avec beaucoup plus d'équipes et quelque modifs de présentation (sans changer l'ordre et le nombre de colonnes...).
Je suis franchement admiratif
Amicalement.
Fabrice,
Bonsoir à tous, Forum,
J'ai fait un test "grandeur nature" avec 86 équipes inscrites. Pour le 1er tirage, aucun problème. Pour le 2ème tirage, la partie "gagnants entre eux" (colonnes O et R) fonctionne mais pour la partie "perdants entre eux" il y a visiblement un problème... Les colonnes U et X ne s'alimentent pas correctement et on constate que l'équipe 22 est prise 2 fois (une fois dans les gagnants mais c'est normal puisqu'il n'y a que 43 équipes...) et encore une fois dans les perdants...
Je joins le fichier avec les 86 équipes pour plus de clarté.
Désolé vba-new mais je ne suis pas assez fort pour modifier tes formules...
Merci d'avance pour tout.
Amicalement.
Fabrice,
Bonjour fabrice, forum,
On va y arriver, c'est rien de bien grave. C'est parce qu'il y a des valeurs à partir de la cellule K67 de la feuille Tirage. Valeurs que je n'avais pas trouvées dans ton précédent fichier, d'où la formule qui ne marche pas dans ton nouveau fichier.
Remplace la formule en U3 par celle-ci :
=SI(NBVAL($K$3:K3)<=MAX(participants)/4;K3;"")et celle en X3 par celle-ci :
=SI(MAX(participants)/2-LIGNES($1:1)>=MAX(participants)/4;DECALER($K$3;MAX(participants)/2-LIGNES($1:1);;;);"")Formules à tirer vers le bas. Ça devrait le faire !
Bonjour à tous, Forum, vba-new,
Merci de ton optimisme vba-new et de ta patience... Je refais le test le plus rapidement possible et te tiens au courant.
Je n'ai jamais trop douté de l'issue de cette opération (un peu quand même
Bref, je teste et te redis...
Merci encore à toi.
Amicalement.
Fabrice,
Bonjour à tous, Forum,
vba-new, les formules fonctionnent impeccablement bien pour le 2e tirage. Maintenant, la macro a l'air également de prendre les bons numéros mais j'ai encore un souci... Elle ne s'arrête pas.
C'est vraiment rageant car je crois que la macro effectue le tirage tel que je le veux...
A la maison, je suis avec Excel 2007 mais le fichier est sauvegardé en 2003 (excel 2007 n'est pas encore sur toutes les machines...).
Penses-tu que cela pourrait venir de là ?
Merci de ta réponse et de tout ce que tu as fait dans ce projet.
Amicalement.
Fabrice,
Bonjour fabrice, forum,
Alors là, je ne sais pas trop d'où ça vient. Si tu pouvais me passer le fichier (anonymisé si besoin) sur lequel la macro bugge je pourrais faire des tests de mon côté.
Au pire, si ça vient de la macro, je peux peut-être mettre une limite de temps d'exécution qui si elle est dépassée, la macro s'arrête.
Quand tu dis qu'elle ne s'arrête pas, c'est à chaque fois que tu exécutes la macro ? Ou bien c'est de temps à autre ?
Bonjour, Forum, vba-new,
En fait, j'ai lancé 2 fois la macro et à chaque fois les numéros d'équipes s'affichaient dans les bonnes colonnes et, il me semble, avec le tirage désiré. Mais une fois la dernière ligne écrite, le sablier reste et je ne peux rien faire d'autre... Je suis même obligé de sortir "brutalement" d'excel, donc sans pouvoir sauvegarder, et donc sans pouvoir contrôler la pertinence du tirage par la macro.
Si tu veux, je te refais passer le fichier ce soir (là, je suis au boulot...) et tu pourras tester. Je laisserai les résultats des 2 premières parties et tu n'auras qu'à lancer la macro.
Amicalement.
Fabrice,
-- Mer Mar 24, 2010 8:32 pm --
Re- tout le monde,
Ci-joint vba-new, le fichier pour que tu puisses essayer. Tu n'as plus, en principe, qu'à lancer la macro pour le 3e tirage.
Merci d'avance.
Amicalement.
Fabrice,
Bonjour à tous, fabrice,
C'est un problème avec ma macro. Voici la nouvelle version re-bricolée
Sub tirageAlea()
Dim a As Long, b&, i&, j&, k&, lg&, ld&, temp&, maxi&, cpt&, cpt2&, cpt3&, cpt4&, dercol&, derlign&, derlignTmp&
Dim tabl, test As Boolean, num As Range
If ActiveSheet.Name <> "Tirage" Then MsgBox "Vous n'êtes pas sur la feuille ""Tirage"" !", vbExclamation: Exit Sub
Range("AM3:AN" & [AM65536].End(xlUp).Row).ClearContents 'efface la plage des colonnes AM et AN
'Application.ScreenUpdating = False
If [AB2] <> 1 Then
i = 3
j = 40
k = 3
derlignTmp = Sheets("Résultats").[bc:bc].Find("*", , xlValues, , xlByRows, xlPrevious).Row
Do While Range("AK" & i) <> " - "
j = IIf(j = 40, 39, 40)
lg = Val(Range("AK" & i))
ld = Right(Range("AK" & i), Len(Range("AK" & i)) - Len(CStr(lg)) - 3)
Set num = Sheets("Résultats").Range("BC10:BC" & derlignTmp).Find(lg, LookIn:=xlValues)
If num.Offset(, 5) = "OUI" Then
Cells(k, j) = lg
Else
Cells(k, j) = ld
End If
k = IIf(j = 39, k, k + 1)
i = i + 1
Loop
End If
derlignTmp = IIf([AM65536].End(xlUp).Row + 1 = 2, 3, [AM65536].End(xlUp).Row + 1)
maxi = Application.WorksheetFunction.Max(Sheets("Inscriptions").[C5:C132].Value)
'dimension = Application.WorksheetFunction.Fact(maxi) / Application.WorksheetFunction.Fact(maxi - 2) / 2
ReDim tabl(1 To maxi, 1 To 2)
For i = 3 To [c:c].Find("*", , xlValues, , xlByRows, xlPrevious).Row
tabl(i - 2, 1) = Range("C" & i).Value
tabl(i - 2, 2) = Range("F" & i).Value
cpt = cpt + 1
Next i
cpt2 = cpt
For i = 3 To [o:o].Find("*", , xlValues, , xlByRows, xlPrevious).Row
tabl(i + cpt - 2, 1) = Range("O" & i).Value
tabl(i + cpt - 2, 2) = Range("R" & i).Value
cpt2 = cpt2 + 1
Next i
cpt3 = cpt2
For i = 3 To [u:u].Find("*", , xlValues, , xlByRows, xlPrevious).Row
tabl(i + cpt2 - 2, 1) = Range("U" & i).Value
tabl(i + cpt2 - 2, 2) = Range("X" & i).Value
cpt3 = cpt3 + 1
cpt4 = cpt4 + 1
Next i
temp = cpt4
tirage:
If test Then Range("AM" & derlignTmp & ":AN" & [AM65536].End(xlUp).Row).ClearContents 'efface la plage des colonnes AM et AN
cpt4 = temp / 2
dercol = [AM65536].Column
Do While Application.WorksheetFunction.Count([AM:AM]) < cpt3 / 2 - 1
recommence:
test = False
If Cells(Range("AM65536").End(xlUp).Row, dercol) <> "" And _
Cells(Range("AM65536").End(xlUp).Row, dercol + 1) = "" Then
a = Cells(Range("AM65536").End(xlUp).Row, dercol)
Else
a = [int(max(participants)*rand()+1)]
Do While test = False
For i = 3 To IIf([AM65536].End(xlUp).Row = 1, 3, [AM65536].End(xlUp).Row)
For j = dercol To dercol + 1
If a = Cells(i, j) Then test = True
If test Then Exit For
Next j
If test Then Exit For
Next i
If test = False Then
Exit Do
Else
test = False
a = [int(max(participants)*rand()+1)]
End If
Loop
End If
b = [int(max(participants)*rand()+1)]
Do While test = False
For i = 3 To IIf([AM65536].End(xlUp).Row = 1, 3, [AM65536].End(xlUp).Row)
For j = dercol To dercol + 1
If b = Cells(i, j) Or b = a Then test = True
If test Then Exit For
Next j
If test Then Exit For
Next i
If test = False Then
Exit Do
Else
test = False
b = [int(max(participants)*rand()+1)]
End If
Loop
For i = 1 To cpt3
If a = tabl(i, 1) And b = tabl(i, 2) Or _
a = tabl(i, 2) And b = tabl(i, 1) Then test = True
If test Then Exit For
Next i
If test And Cells(Range("AM65536").End(xlUp).Row, dercol) <> "" And _
Cells(Range("AM65536").End(xlUp).Row, dercol + 1) <> "" And cpt4 = cpt3 / 2 - 1 Then GoTo tirage
If test Then GoTo recommence
cpt4 = cpt4 + 1
derlign = IIf([AM65536].End(xlUp).Row + 1 = 2, 3, [AM65536].End(xlUp).Row + 1)
If Cells(derlign - 1, dercol) <> "" And _
Cells(derlign - 1, dercol + 1) = "" Then
Cells(derlign - 1, dercol + 1) = b
Range(Cells(derlign - 1, dercol + 1), Cells(derlign - 1, dercol + 1)).Select
Else
Cells(derlign, dercol) = a: Cells(derlign, dercol + 1) = b
Range(Cells(derlign, dercol), Cells(derlign, dercol)).Select
End If
Loop
a = -1
b = -1
For k = 1 To cpt3
For i = 3 To [AM65536].End(xlUp).Row
For j = dercol To dercol + 1
If k = Cells(i, j) Then test = True
If test Then Exit For
Next j
If test Then Exit For
Next i
If test = False Then
Select Case a
Case Is < 0
a = k
Case Else
b = k
End Select
End If
test = False
If b > 0 Then Exit For
Next k
For i = 1 To cpt3
If a = tabl(i, 1) And b = tabl(i, 2) Or _
a = tabl(i, 2) And b = tabl(i, 1) Then test = True
If test Then Exit For
Next i
If test Then
GoTo tirage
ElseIf test = False And a > 0 And b > 0 Then
Cells(derlign + 1, dercol) = a: Cells(derlign + 1, dercol + 1) = b
End If
End SubBonjour à tous, Forum,
Waouhhhhh !!!! Encore une fois très impressionnant vba-new. Je suis extrêmement flatté que tu puisses consacrer autant d'énergie pour régler mon problème...
Je teste ce week-end et te tiens au courant.
Merci encore et bon week-end.
Amicalement.
Fabrice,
Bonsoir à tous, Forum,
Après 2 tests dans des conditions réelles, CA MARCHE !!!
Vraiment super ce que tu as fait pour moi, vba-new... Tu vas me supprimer pratiquement tous les risques d'erreur et me faire gagner un temps considérable lors du tirage au sort.
Avant de passer le post en "résolu", j'aimerai faire encore quelques petit tests mais je suis maintenant plus que confiant.
Encore un énorme merci à toi et à bientôt, peut-être, sur un autre fil.
Amicalement.
Fabrice,
Bonjour à tous, Forum,
J'ai effectué quelques tests supplémentaires et, malheureusement, j'ai remarqué qu'avec une douzaine d'équipes la macro n'exécutait pas exactement ce que je souhaite pour le dernier tirage...
Sur les 3 équipes qui ont gagné 2 parties, la macro devrait en faire rencontrer au moins 2 entre elle. Et là, ce n'est pas le cas.
Ci-joint l'exemple :
Vraiment désolé vba-new mais si je peux encore t'embêter un peu...
Merci d'avance.
Amicalement.
Fabrice,
