Tirage au sort aléatoire avec critères

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.
 

Fichiers joints

Dernière édition:

JBARBE

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

Bonjour à tous, Bonjour Dranreb,

J'ai observé un bug dans ta macro ( voir image ) !

Bonne journée !
 

Fichiers joints

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
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Voyez si vous pouvez adapter la programmation du fichier joint poste #24 à la présentation de votre feuille d'inscriptions et des résultats souhaités.
 

Dranreb

XLDnaute Barbatruc
Tant mieux, justement moi par contre je ne sais pas.
Donc arrangez vous pour que le tableau VBA en mémoire Te contienne ce qu'il faut.
 
Dernière édition:

Discussions similaires


Haut Bas