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.
 

Pièces jointes

  • Cestalain.xlsm
    12.6 KB · Affichages: 121

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+
 

Pièces jointes

  • Cestalain solution finale avec 4 tours x 10 rencontres(1).xlsm
    29.7 KB · Affichages: 61

cestalain

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

Bonjour Job75, Dranreb,

Je viens de tester vos propositions et c'est vraiment nickel !
La solution de Job75 correspond bien à ma requête, celle de Dranreb est très intéressante également car elle introduit un autre critère qui peut tout a fait être pris en compte pour ce projet. Je vais profiter également des commentaires dans le VBA pour comprendre vos méthodes et ainsi progresser.
Encore merci à vous deux pour votre aide.
Cestalain
 

Dranreb

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

Bonjour.
Ouh là ! Je m'étais dit hier soir que ma programmation aurait bien besoin de commentaires explicatifs et d'une simplification d'architecture.
Je vais regarder pour améliorer cela, car actuellement seul le module de classe ListeAléat est bien documenté.
 

job75

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

Bonjour cestalain, Bernard, le forum,

On peut se passer des tableaux auxiliaires en utilisant des objets Dictionary.

Voyez les fichiers joints avec 3 et 4 critères, le 4ème critère étant, comme l'a utilisé Bernard, "Chaque équipe doit rencontrer des groupes différents".

Le code pour les 4 critères :

Code:
Const ntirages = 10000 'nombre maximum de tirages
Dim n&, equip$(), DicoCrit2 As Object, DicoCrit4 As Object, compte() As Boolean

Sub Tirages()
Dim E As Range, i&, T As Range, j%, tablo, tir&, r1, x1$, r2, x2$, y$, k&
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, 1 To 5)
For Each E In E
  If E <> "" And i < n Then i = i + 1: equip(i, 1) = E
Next
Set T = [H4].Resize(n, 8) 'tableau à renseigner
For j = 2 To 8 Step 2
  T.Columns(j).Resize(1000) = "" 'RAZ
Next j
Set DicoCrit2 = CreateObject("Scripting.Dictionary")
Set DicoCrit4 = CreateObject("Scripting.Dictionary")
tablo = T: Randomize
'---tirages aléatoires avec respect des 4 critères---
1 If tir < ntirages Then
  tir = tir + 1
  DicoCrit2.RemoveAll: DicoCrit4.RemoveAll 'RAZ
  For j = 2 To 8 Step 2
    ReDim compte(1 To n) 'RAZ
    For i = 1 To n Step 2
2     r1 = Int(1 + Rnd * n)
      If compte(r1) Then GoTo 2
      x1 = equip(r1, 1): compte(r1) = True
      If Not Verif(x1) Then GoTo 1
3     r2 = Int(1 + Rnd * n)
      x2 = equip(r2, 1)
      y = IIf(x1 < x2, x1 & x2, x2 & x1)
      If Left(x1, 3) = Left(x2, 3) Or DicoCrit2.exists(y) Or _
        DicoCrit4.exists(x1 & Left(x2, 3)) Or DicoCrit4.exists(x2 & Left(x1, 3)) _
          Or compte(r2) Then GoTo 3
      DicoCrit2(y) = ""
      DicoCrit4(x1 & Left(x2, 3)) = "": DicoCrit4(x2 & Left(x1, 3)) = ""
      tablo(i, j) = x1: tablo(i + 1, j) = x2: compte(r2) = True
  Next i, j
End If
'---restitution---
T = tablo
tablo = DicoCrit2.keys
For i = 1 To n
  j = 2
  For k = 0 To UBound(tablo)
    If InStr(tablo(k), equip(i, 1)) Then _
      equip(i, j) = Replace(tablo(k), equip(i, 1), ""): j = j + 1
Next k, i
With Range("A19:E" & Rows.Count)
  .ClearContents
  .Resize(n) = equip
  .Sort .Columns(1), Header:=xlNo 'tri
End With
Application.ScreenUpdating = True
MsgBox tir & IIf(tir = 1, " tirage a suffi...", " tirages ont été nécessaires...")
End Sub

Function Verif(x1$) As Boolean
Dim i&, x2$, y$
For i = 1 To n
  x2 = equip(i, 1)
  y = IIf(x1 < x2, x1 & x2, x2 & x1)
  If Left(x1, 3) <> Left(x2, 3) And Not DicoCrit2.exists(y) And _
    Not DicoCrit4.exists(x1 & Left(x2, 3)) And Not DicoCrit4.exists(x2 & Left(x1, 3)) _
      And Not compte(i) Then Verif = True: Exit Function
Next
End Function
Bonne soirée.
 

Pièces jointes

  • Cestalain avec Dictionary 3 critères(1).xlsm
    24.9 KB · Affichages: 41
  • Cestalain avec Dictionary 4 critères(1).xlsm
    28.1 KB · Affichages: 39
Dernière édition:

Dranreb

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

Bonjour.
Ah, oui, tiens. On n'en parle plus de ce PtrSafe.
Je l'ai mis pour voir un coup, ce qui n'a rien changé, puis j'ai oublié de l'enlever.
Quelqu'un sait il pourquoi il n'est plus indispensable sur un CPU 64 bits ?
 

marco29

XLDnaute Nouveau
bon jour je débute sur le forum je c est pas trop comment ça fonctionne,
j ai un soucis que je n arrive pas a résoudre je fouille et trouve pas peut être vue vos connaissance vous allez pouvoir m aider et je vous en remercie
pour mon club j ai besoin de faire un tirage au sort avec 4 clubs , dans chaque club il y a entre 15 et 25 équipes c variable selon les inscriptions.
le but c est que c est équipe ne se rencontrent pas une 2 fois et et que les équipes du même club ne tombe pas ensemble ,et ceci sur 3 tours
merci infiniment coordialement
 

Statistiques des forums

Discussions
311 723
Messages
2 081 932
Membres
101 844
dernier inscrit
pktla