Tirage au sort aléatoire avec critères

[cestalain]

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.

 

[job75]

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 :

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+

 

[Dranreb]

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

Bonsoir.

Autre solution.

 

[job75]

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 :

=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.

 

[Dranreb]

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…)

 

[job75]

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+

 

[job75]

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.

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+

 

[job75]

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" :

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+

 

[job75]

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 :

  '---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.

 

[Dranreb]

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]

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+

 

[Dranreb]

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]

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 :

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+

 

[job75]

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]

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

Bonsoir à tous

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