Tirage au sort aléatoire avec critères

cestalain

XLDnaute Nouveau
Bonjour à tous,

Je me tourne vers vous car je bloque sérieusement pour réaliser un tirage au sort avec conditions.

Je joint un fichier avec explications.

Merci d'avance de votre aide.
 

Fichiers joints

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonjour cestalain,

Voyez le fichier joint et les 3 tableaux auxiliaires en colonnes Q:X avec leurs formules.

La macro du bouton permet de réaliser 10000 tirages aléatoires :

Code:
Sub Tirages()
Dim ntirages, a$(), c As Range, n&, mini, t1, t2, t3, t4
ntirages = 10000 'modifiable
Application.ScreenUpdating = False
'---préparation et formule avec ALEA.ENTRE.BORNES---
ReDim a(1 To Application.CountA([A2:F5]), 1 To 1)
For Each c In [A2:F5]
  If c <> "" Then n = n + 1: a(n, 1) = c
Next
ThisWorkbook.Names.Add "Equipes", a 'nom défini
[I4:I21,K4:K21,M4:M21,O4:O21] = "=INDEX(Equipes,RANDBETWEEN(1," & n & "))"
mini = 1000
'---tirages aléatoires---
For n = 1 To ntirages
  Calculate
  If [B18] < mini Then 'mémorisation du minimum
    mini = [B18]
    t1 = [I4:I21]: t2 = [K4:K21]
    t3 = [M4:M21]: t4 = [O4:O21]
  End If
  If mini = 0 Then Exit For
Next
'---restitution---
[I4:I21] = t1: [K4:K21] = t2
[M4:M21] = t3: [O4:O21] = t4
End Sub
Il faut faire en général plusieurs essais pour que les 2 critères soient respectés (valeur zéro en B18).

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonjour cestalain, Bernard, le forum,

J'ai ajouté une MFC sur les colonnes I K M O pour visualiser les rencontres où l'un des 2 critères n'est pas respecté, formule en I4 :

Code:
=OU(""&R21:R22="0";""&R39:R40="0")
Cela augmente de très peu la durée d'exécution, chez moi 13,8 s au lieu de 13,7 s pour 10000 tirages.

Fichier (2).

Edit : on remarquera que le non-respect du 1er critère est beaucoup plus fréquent que celui du 2ème.

Bonne journée.
 

Fichiers joints

Dernière édition:

Dranreb

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonjour.

C'est sur que les contraintes sont un peu insuffisantes:
1 — Aucune équipe du même Groupe ne peuvent se rencontrer
2 — Aucune équipe ne peut rencontrer la même deux fois
C'est tout.
Mais:
3 — Une équipe pourrait très bien ne pas participer au tournoi du fait que le hasard ne l'aurait jamais désignée, tandis qu'une autre apparaitrait 5 ou 6 fois dans chaque tour ?
4 — Une équipe pourrait très bien ne rencontrer que des équipes adverses d'un même groupe autre que le sien pourvu que c'en soit une différente à chaque fois ?
Dans ma solution, le point 4 risque d'arriver, mais pas le 3, à condition seulement que leur nombre total soit pair, parce qu'alors chaque équipe joue quelque part 1 fois dans chaque tour. Or dans l'exemple ce nombre n'était pas pair. Alors, que faut il en penser ?
J'ai ajouté un récapitulatif des rencontres à droite du tableau, et je suis justement tombé sur un tirage ou une équipe, Bor1, ne joue que 2 fois à cause du nombre total impair d'équipes.

Tu me dira, Job75, c'est déjà bien de respecter les contraintes qu'il demande, et il n'y a pas lieu d'en respecter d'autres en plus qu'il ne demande pas ! (et s'il change d'avis avec autre chose, et bien tant pis pour lui d'avoir loupé le coche en n'exposant pas dès le début la totalité du problème. On ne va quand même pas poursuivre une discussion où le demandeur change d'avis sans arrêt…)
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Re,

Très bonne analyse des critères Bernard.

Dans le fichier joint j'ai ajouté le 3ème critère "Toutes les équipes jouent au moins une fois".

Le non-respect de ce critère n'est pas très fréquent.

La durée d'exécution passe à 16,8 s pour 10000 tirages.

A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Re,

Dans ce fichier (2) voici une solution bien meilleure :

- on n'entre plus de formules dans la feuille de calcul, la macro calcule elle-même des nombres aléatoires

- le critère 1 est respecté à la source en calculant au besoin un autre nombre aléatoire.

Code:
Sub Tirages()
Dim ntirages, T As Range, equip$(), c As Range, n&, tablo
Dim nlig&, ncol%, mini, tir&, i&, j%, mem
ntirages = 50 'modifiable
Set T = [I4:O21] 'tableau à renseigner
Application.ScreenUpdating = False
'---préparation---
ReDim equip(1 To Application.CountA([A2:F5]))
For Each c In [A2:F5]
  If c <> "" Then n = n + 1: equip(n) = c
Next
tablo = T: nlig = UBound(tablo): ncol = UBound(tablo, 2)
mini = 1000
Randomize
'---tirages aléatoires---
For tir = 1 To ntirages
  For i = 1 To nlig Step 2
    For j = 1 To ncol Step 2
      tablo(i, j) = equip(Int(1 + Rnd * n))
1     tablo(i + 1, j) = equip(Int(1 + Rnd * n))
      '---test pour le critère 1---
      If Left(tablo(i, j), 3) = Left(tablo(i + 1, j), 3) Then GoTo 1
  Next j, i
  T = tablo
  If [B18] < mini Then mini = [B18]: mem = tablo 'mémorisation
  If mini = 0 Then Exit For
Next tir
'---restitution---
T = mem
End Sub
C'est très rapide puisque 50 tirages suffisent (100 serait mieux mais c'est pour qu'on voit les MFC de temps en temps).

A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Re,

Dans ce fichier j'ai introduit un 4ème critère "Optimiser le nombre de rencontres par équipe" :

Code:
Sub Tirages()
Dim ntirages, T As Range, equip$(), c As Range, n&, tablo, nlig&, ncol%
Dim mini, maxrencontre, tir&, i&, j%, mem, minrencontre
ntirages = 1000 'modifiable
Set T = [I4:O21] 'tableau à renseigner
Application.ScreenUpdating = False
'---préparation---
ReDim equip(1 To Application.CountA([A2:F5]))
For Each c In [A2:F5]
  If c <> "" Then n = n + 1: equip(n) = c
Next
tablo = T: nlig = UBound(tablo): ncol = UBound(tablo, 2)
mini = 1000: maxrencontre = 1000
Randomize
'---tirages aléatoires---
For tir = 1 To ntirages
  For i = 1 To nlig Step 2
    For j = 1 To ncol Step 2
      tablo(i, j) = equip(Int(1 + Rnd * n))
1     tablo(i + 1, j) = equip(Int(1 + Rnd * n))
      '---test pour le critère 1---
      If Left(tablo(i, j), 3) = Left(tablo(i + 1, j), 3) Then GoTo 1
  Next j, i
  T = tablo
  If [A7] < mini Then mini = [A7]: mem = tablo 'mémorisation
  '---optimisation du nombre de rencontres (critère 4)---
  If [A7] = 0 Then _
    If [B9] >= minrencontre And [B10] <= maxrencontre Then _
      minrencontre = [B9]: maxrencontre = [B10]: mem = tablo
Next tir
'---restitution---
T = mem
End Sub
Je n'ai pas trouvé mieux qu'un nombre de rencontres entre 2 et 5 (cellules B9 et B10).

J'ai conservé les MFC mais avec 1000 tirages elles ne sont plus vraiment utiles.

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonjour cestalain, Bernard, le forum,

Fichier (1 bis) adapté à 10 rencontres par tour.

Pour l'optimisation j'ai trouvé aussi minimum 2 maximum 5 rencontres par équipe.

Edit : j'ai paramétré en C9 une valeur cible à atteindre pour le minimum :

Code:
  '---optimisation du nombre de rencontres (critère 4)---
  If [A7] = 0 Then If [B9] = [C9] Then If [B10] < maxrencontre _
    Then maxrencontre = [B10]: mem = tablo
Bonne journée.
 

Fichiers joints

Dernière édition:

Dranreb

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonjour.
Écoute job75, je crois que le seul but visé c'est exactement 4 rencontres pour chaque équipe, pas une de plus ni de moins.
Mais j'ai l'impression qu'on n'en aura jamais confirmation, vu que le demandeur semble s'en être complètement désintéressé…
 

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Re Bernard,

Exactement 4 rencontres pour chacune des 21 équipes cela fait au total (4x21)/2 = 42 rencontres.

Il faut donc 6 tours x 7 rencontres.

J'ai testé avec le fichier joint (fichier du post #9 adapté), valeur 4 en C9.

Même avec 100.000 tirages je n'ai pas obtenu le résultat souhaité, cela paraît normal en terme de probabilité...

A+
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

J'y arrive bien toujours en 4 tours quand le nombre de participant est suffisant et pair.
Si le demandeur s'y intéressait encore, je pourrais y arriver pour des nombres impairs par une voie légèrement différente. Ça s'apparenterait en effet alors plus au tirage de 42 poules indépendantes de 2 plutôt qu'à 4 tours ou toutes les équipes jouent simultanément, ce qui n'était d'ailleurs pas demandé.
 

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Re,

Voici ma solution finale avec 6 tours x 7 rencontres.

Le 4ème critère est maintenant "Minimiser le nombre de rencontres par équipe".

On obtient alors très facilement 4 rencontres pour chaque équipe avec ce code :

Code:
Const ntirages = 10000 'nombre maximum de tirages
Dim n&, maxrencontre&, equip$(), compte() 'mémorisation

Sub Tirages()
Dim E As Range, T As Range, nlig&, ncol%, tablo, tir&, i&, j%, r, mem
Set E = [A2:F5] 'tableau des équipes
Set T = [H4:S17] 'tableau à renseigner
nlig = T.Rows.Count: ncol = T.Columns.Count
Application.ScreenUpdating = False
'---initialisations---
For n = 2 To ncol Step 2
  T.Columns(n) = "" 'RAZ
Next n
ReDim equip(1 To Application.CountA(E))
n = 0
For Each E In E
  If E <> "" Then n = n + 1: equip(n) = E
Next
maxrencontre = Application.RoundUp(nlig * ncol / n / 2, 0)
tablo = T: Randomize
'---tirages aléatoires avec respect des critères 1 et 4---
Do
  tir = tir + 1
  ReDim compte(1 To n) 'RAZ
  For i = 1 To nlig Step 2
    For j = 2 To ncol Step 2
1     r = Int(1 + Rnd * n)
      If compte(r) = maxrencontre Then GoTo 1
      If Not Verif(Left(equip(r), 3)) Then GoTo 3
      tablo(i, j) = equip(r): compte(r) = compte(r) + 1
2     r = Int(1 + Rnd * n)
      If Left(tablo(i, j), 3) = Left(equip(r), 3) Or _
        compte(r) = maxrencontre Then GoTo 2
      tablo(i + 1, j) = equip(r): compte(r) = compte(r) + 1
  Next j, i
  T = tablo
3 Loop While [A7] And tir < ntirages
Application.ScreenUpdating = True
MsgBox tir & IIf(tir = 1, " tirage a suffi...", " tirages ont été nécessaires...")
End Sub

Function Verif(x$) As Boolean
Dim i
For i = 1 To n
  If Left(equip(i), 3) <> x And compte(i) < maxrencontre _
    Then Verif = True: Exit Function
Next
End Function
Edit : j'ai modifié pour que maxrencontre soit calculé par la macro.

Bien d'accord avec toi Bernard, avec 21 équipes on pourrait utiliser aussi bien 1 tour x 42 rencontres.

Ou 2 tours x 21 rencontres ou 3 tours x 14 rencontres, ou encore inverser tours et rencontres...

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Re Bernard,

Pour finir, je reviens sur la question de parité dont tu parlais au poste #5.

C'est le produit (nombre d'équipes) x (nombre de rencontres par équipe) qui doit être pair.

Sinon il n'est pas possible que les équipes aient toutes le même nombre de rencontres.

A+
 

Lone-wolf

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonsoir à tous :)

Après tout ce travail...où est passez cestalain??? :confused:
 

cestalain

XLDnaute Nouveau
Re : Tirage au sort aléatoire avec critères

Bonjour Job75 ,Dranreb , Lone Wolf

Tout d'abord je tiens à, tous, vous remercier de votre aide.
Je n'ai pu lire vos messages jusqu'à aujourd'hui n'ayant pas d'ordi loin de chez moi.
La j'ai pu me connecté chez des amis mais je ne peux tester vos travaux.
Dès mon retour je vous tiendrai au courant soyez en sur.
En lisant vos commentaires je vous confirme seulement que chaque équipe doit participer à chaque tour.
Encore merci pour votre dévouement
 

cestalain

XLDnaute Nouveau
Re : Tirage au sort aléatoire avec critères

Re bonjour

J'ai des amis formidables, un de leurs ordi possède excel !!
Si j'avais pu voir vos messages je vous aurai évité de partir sur une mauvaise piste.
Mauvaise piste du à une mauvaise explication de ma part, je m'en excuse, et en plus,
Je me suis rendu compte que mon exemple comporté 21 équipes alors que ce ne peut etre qu'un nombre pair car une equipe en rencontre une autre .
A chaque tour chaque équipe ne fait qu'une partie.

Donc en partant d'un nombre de 20 équipes par exemple ( nombre pair )
-Il y aura 10 rencontres (Une équipe en rencontrant une autre) Ex: Par1 contre Lyo2 , Nic3 contre Bor4 etc.....
_
Au tour1 il suffit donc que deux équipes du meme groupe ne se rencontre pas. ( critère 1 )

Pour les tours suivants Tour2, Tour3, Tour4

- Toujours le critère 1 (que deux equipes du meme groupe ne se rencontre pas) mais aussi
que deux équipes qui se sont rencontrées aux tour précédent ne se rencontre à nouveau (critère 2)

J'espère que ces nouvelles précisions seront plus claires pour vous.
Merci encore pour votre aide et mes excuses pour ces infortunes.

cestalain.
 

Dranreb

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonjour.
Voir ma proposition poste #5
Chaque tirage fait exactement ça.
Le seul bémol, mais ce n'était pas demandé, l'algorithme ne cherche pas à maximiser le nombre de groupes différents auxquels appartiennent les adversaires rencontrés, et donc il peut arriver qu'une équipe ne rencontre par hasard que celles d'un seul autre groupe (du moins s'il en comporte 4).

Remarque: J'ignore s'il y aurait des solutions si la règle 2 avait été: Une équipe ne peut en rencontrer qu'une seule d'un groupe donné. Mais je peux essayer si ça vous intéresse…
Ça moulinerait forcément beaucoup plus parce que chaque rencontre retenue éliminerait non seulement la possibilité d'une seconde rencontre avec elle, mais aussi d'une rencontre avec toute les autres équipes de son groupe.
 
Dernière édition:

job75

XLDnaute Barbatruc
Re : Tirage au sort aléatoire avec critères

Bonjour cestalain, Bernard, le forum,

En effet le 3ème critère "Chaque équipe doit participer à chaque tour" est logique.

Et en effet le nombre d'équipes doit être pair.

La macro utilise les mêmes méthodes que précédemment :

Code:
Const ntirages = 10000 'nombre maximum de tirages
Dim n&, equip$(), compte() As Boolean 'mémorisation

Sub Tirages()
Dim E As Range, i&, T As Range, j%, tablo, tir&, r
Set E = [A1].CurrentRegion.Offset(1) 'tableau des équipes
Application.ScreenUpdating = False
'---initialisations---
n = 2 * Int(Application.CountA(E) / 2) 'nombre pair
ReDim equip(1 To n)
For Each E In E
  If E <> "" And i < n Then i = i + 1: equip(i) = E
Next
Set T = [H4].Resize(n, 8) 'tableau à renseigner
For j = 2 To 8 Step 2
  T.Columns(j) = "" 'RAZ
Next j
tablo = T: Randomize
'---tirages aléatoires avec respect des critères 1 et 3---
Do
  tir = tir + 1
  For j = 2 To 8 Step 2
    ReDim compte(1 To n) 'RAZ
    For i = 1 To n Step 2
1     r = Int(1 + Rnd * n)
      If compte(r) Then GoTo 1
      If Not Verif(Left(equip(r), 3)) Then GoTo 3
      tablo(i, j) = equip(r): compte(r) = True
2     r = Int(1 + Rnd * n)
      If Left(tablo(i, j), 3) = Left(equip(r), 3) Or compte(r) Then GoTo 2
      tablo(i + 1, j) = equip(r): compte(r) = True
  Next i, j
  T = tablo
3 Loop While [A7] And tir < ntirages
Application.ScreenUpdating = True
MsgBox tir & IIf(tir = 1, " tirage a suffi...", " tirages ont été nécessaires...")
End Sub

Function Verif(x$) As Boolean
Dim i
For i = 1 To n
  If Left(equip(i), 3) <> x And Not compte(i) Then Verif = True: Exit Function
Next
End Function
Fichier joint.

Il n'y a plus de MFC mais j'ai ajouté un tableau de vérification.

A+
 

Fichiers joints

Discussions similaires


Haut Bas