Tirage au sort avec contraintes

baboo1er · 20 Mars 2014

Bonjour,

Ça y est j'en suis arrivé au point de non-retour 😛... il me faut de l'aide!

J'ai un fichier Excel pour lequel j'ai 20 équipes, 10 sports et 10 créneaux horaires.
le but est de tirer de manière aléatoires des rencontres avec les 3 contraintes suivantes :
-Une équipe ne peut être qu'une fois dans un créneau horaire (elle ne peut pas faire 2 sports en même temps!)
-Une équipe ne rencontrer qu'une seule et unique fois une autre équipe
-Une équipe ne passer qu'une fois sur un sport (comme il y a 10 créneaux horaires pour 10 sports, 1 créneau = 1 sport par équipe)

Je vous mets mon fichier à dispo avec ma macro vba. Elle fonctionne mais elle tourne en boucle depuis plus de 3 jours sans jamais réussir à trouver la bonne séquence car il y a en a un certain nombre (20 équipes fois 10 créneaux horaires fois 10 sports.....😕)

Merci de votre aide et svp plait penser à mettre des explications sur les lignes des code afin que je comprennes et que j'apprenne... j'ai des collègues au boulot qui compte sur ma transmission d"informations nouvelles en vba.

a vous lire

Baboo1er

L'intelligence c'est comme un parachute, quand on n'en pas, on s'écrase.... Et je m'écrase vitesse TGV en ce moment!

Dranreb · 20 Mars 2014

Re : Tirage au sort avec contraintes

Bonjour.

Essayez de mettre au point une seule solution manuellement, quitte à la baser sur des rotations de nombre régulièrement disposés, la première ligne contenant de 1 à 20 dans l'ordre 1 contre 2, 3 contre 4 etc.
Si une seule telle solution existe, elle peut servir à en produire d'autres en mélangeant les ordres des numéros d'équipes, des lignes du tableau et de ses paires de colonnes.

baboo1er · 20 Mars 2014

Re : Tirage au sort avec contraintes

Bonjour Danred,

Merci du conseil, néanmoins :

*J'ai essayé de le faire manuellement, et j'ai toujours des doublons...
*J'ai essayé aussi de décaler mes "points de départ" en commencant par le creneau 1 par le sport 1, et l'equipe 1 puis le creneau 2, sport 2 eéquipe 2 mais en vain...
*J'ai même fais un autre version en oisolant les seules combinaisons possibles... mais encore en vain

Là, il me faut une solution vba, denombrement, hypothèse... tout le touintouin quoi 😉

merci à toi

Dranreb · 20 Mars 2014

Re : Tirage au sort avec contraintes

Si même une démarche très ordonnée, en décalant à chaque ligne les numéros d'un pas modulo 20 ne parvient pas à déterminer une solution, peut être n'en existe-t-il pas ? En tout cas si vous en trouvez ne serait-ce qu'une seule, gardez la précieusement de coté !

KenDev · 23 Mars 2014

Re : Tirage au sort avec contraintes

Bonjour à tous,

Je ne sais pas si une solution existe mais, (en attendant mieux ?), un résultat à 98% :

1;2 / 4;9 / 8;15 / 12;19 / 11;20 / 3;16 / 7;18 / 6;17 / 5;13 / 10;14
5;6 / 14;19 / 1;11 / 9;16 / 4;13 / 7;10 / 2;20 / 8;12 / 15;17 / 3;18
7;8 / 6;15 / 4;19 / 11;18 / 12;17 / 2;13 / 3;14 / 10;16 / 1;20 / 5;9
9;10 / 7;20 / 3;6 / 2;15 / 1;5 / 11;14 / 4;17 / 13;19 / 8;18 / 12;16
15;16 / 13;18 / 14;17 / 1;4 / 3;8 / 9;12 / 10;19 / 5;11 / 2;7 / 6;20
17;18 / 3;12 / 10;13 / 6;7 / 2;14 / 8;19 / 5;16 / 4;20 / 9;11 / 1;15
19;20 / 2;17 / 5;18 / 8;13 / 7;16 / 1;6 / 12;15 / 9;14 / 3;10 / 4;11
13;14 / 5;10 / 2;16 / 3;20 / 6;9 / 15;18 / 8;11 / 1;7 / 4;12 / 17;19
3;4 / 11;16 / 7;12 / 5;14 / 10;15 / 17;20 / 1;9 / 2;18 / 6;19 /
11;12 / 1;8 / 9;20 / 10;17 / 18;19 / 4;5 / 6;13 / 3;15 / 14;16 /

8;13 et 2;7 complètent cette grille mais sont déjà précédemment apparues.

Cordialement

KD

Dranreb · 23 Mars 2014

Re : Tirage au sort avec contraintes

Bonjour.

Bien KenDev. J'essayai aussi de temps à autre, sans trouver de solution. Il semblerait que 20 soient très gênant pour trouver une solution par glissements. Avec 18 ou 22 ça irait mieux… Avec 22 ça permettrait de trouver une solution pour 20 mais avec un 11ième créneau horaire supplémentaire et 2 exempts à chacun.

KenDev · 23 Mars 2014

Re : Tirage au sort avec contraintes

Re,

Bonjour Dranreb,

Cette solution provient d'une macro qui suit une logique un peu différente, mais pas sans rapport avec l'idée de glissement du moins pour le travail pré-macro.

Partie 0, à la main : choisir 100 combinaisons sans répétitions parmi les 190 de C(20,2) tels que chaque n° apparaissent 19*. Ceci est la partie avec l'idée de glissement, le choix :
1;2/1;3/1;4/1;5/1;6/1;7/1;8/1;9/1;10/1;11/2;12/2;13/2;14/2;15/2;16/2;17/2;18/2;19/2;20/3;4/3;6/3;8/3;10/3;12/3;14/3;16/3;18/3;20/4;5/4;7/4;9/4;11/4;13/4;15/4;17/4;19/5;6/5;8/5;10/5;12/5;14/5;16/5;18/5;20/6;7/6;9/6;11/6;13/6;15/6;17/6;19/7;8/7;10/7;12/7;14/7;16/7;18/7;20/8;9/8;11/8;13/8;15/8;17/8;19/9;10/9;12/9;14/9;16/9;18/9;20/10;11/10;13/10;15/10;17/10;19/11;12/11;14/11;16/11;18/11;20/12;13/12;15/12;17/12;19/13;14/13;16/13;18/13;20/14;15/14;17/14;19/15;16/15;18/15;20/16;17/16;19/17;18/17;20/18;19/19;20

Sub, partie 1 : dans le tableau final (10*10) essayer de remplir le maximum de colonnes seulement avec ces 100. Il semblerait que le maximum obtenu dans un temps raisonable soit 7 ou 8. On garde ces 7 ou 8 colonnes.

partie 2 : réinjecter les 90 combins écartées aux 20 ou 30 restantes et on retente la même opération pours la/les colonne(s) 8 et 9 ou 9.

partie 3 : simple vérification que la dernière combin de chaque ligne est compatible avec les contraintes.

Je tenterai de faire tourner cette sub sur plusieurs heures pour voir si elle peut faire mieux. J'ai un autre résultat à 98% mais l'idée est d'obtenir un seul 100% à partir duquel il serait facile de générer presque autant de solutions différentes que l'on veut.

Cordialement

KD

Dranreb · 23 Mars 2014

KenDev · 23 Mars 2014

Re : Tirage au sort avec contraintes

Re,

Les conditions pas de répétitions d'équipes en ligne ni en colonnes sont respectées mais pas la condition pas de répétition de matchs :

Les matchs 19;12 et 7;20 apparaissent 3 fois et 20 autres matchs apparaissent 2 fois.

Cordialement

KD

Dranreb · 23 Mars 2014

Re : Tirage au sort avec contraintes

Je me disais aussi que c'était trop beau pour être vrai …

mapomme · 23 Mars 2014

Re : Tirage au sort avec contraintes

Bonjour baboo1er, Dranreb 🙂, KenDev 🙂,

Un essai 😕 de ma part. J'ai tenté d'écrire plusieurs codes; c'est pourquoi le code est un peu brouillon. Je ne vois plus grand chose. Je pense tenir des solutions mais je ne vois plus très clair 😕.

Il faut cliquer sur le bouton tirage. Les paramètres de lignes (créneaux horaires) et nombre d'équipes en colonnes (2 fois le nombre de sports) sont en constante au début du code.

Edit : comme Dranreb, je vais sans doute bientôt dire "Je me disais aussi que c'était trop beau pour être vrai … "

Edit : Je le dis en effet 🙁. (j'ai retiré le fichier)

KenDev · 27 Mars 2014

Re : Tirage au sort avec contraintes

Bonjour à tous,

Ci-joint un fichier parvenant à des solutions en un temps le plus souvent raisonable (mais après quelques suées...) tel que :

1;2 16;17 8;11 12;15 13;20 5;18 6;9 3;19 4;14 7;10
3;4 2;20 6;15 8;17 5;12 9;14 10;18 7;13 16;19 1;11
5;6 1;3 2;19 10;13 8;9 15;20 12;14 16;18 7;11 4;17
7;8 10;15 1;4 2;18 14;19 6;17 3;11 5;20 9;12 13;16
9;10 11;18 3;16 1;5 2;17 12;13 7;19 4;6 8;15 14;20
11;12 7;14 9;20 4;19 1;6 2;16 13;17 8;10 3;5 15;18
13;14 4;9 5;10 3;20 11;16 1;7 2;15 12;17 6;18 8;19
15;16 12;19 13;18 6;7 3;10 4;11 1;8 2;14 17;20 5;9
17;18 5;8 7;12 11;14 4;15 10;19 16;20 1;9 2;13 3;6
19;20 6;13 14;17 9;16 7;18 3;8 4;5 11;15 1;10 2;12

Le code n'est pas très beau... Si la sub est interrompue avant son terme, Excel sera en mode calcul manuel.

Cordialement

KD

Edit : fichier supprimé, voir post suivant

KenDev · 27 Mars 2014

Re : Tirage au sort avec contraintes

Re,

Ci joint un fichier "pratique" alors que le précédent est un fichier de recherche. Celui ci génère immédiatement des grilles dans le format demandé par baboo1er. Il exploite simplement une des solution trouvées par le fichier précédent en mélangeant lignes, colonnes et numéros.

D'autre part j'ai travaillé à partir du fichier fourni et vient de me rendre compte que celui ci contenait trois feuilles cachées assez lourdes. Le fichier précédent va donc être supprimé.

Enfin mes excuses pour la notation 5 étoiles du fil, ayant oublié d'accepter les scripts de googleapplis ou yahooapplis avant de poster, ce qui provoque mystérieusement ce vote automatique.

Cordialement

KD

fichier de Recherche : SPORTS aleatoires_web_KD.xls
fichier 'pratique' : SPORTS aleatoires_web_KD2.xls

Ci dessous le code du 2ème fichier, celui du 1er n'est pas présentable !

VB:

Sub Tir()
    Dim Ta(), Tb&(), Tc&(), Td&(), Te$(), Tf&(), i&, j&, k&
    
    'grille (rang des combins)
    ReDim Tb(1 To 10, 1 To 10)
    Ta = Array(1, 150, 167, 112, 123, 127, 44, 56, 79, 177): i = 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(38, 37, 157, 88, 138, 172, 84, 122, 108, 10): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(71, 2, 36, 136, 65, 169, 173, 158, 121, 101): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(100, 174, 3, 35, 135, 140, 181, 147, 91, 39): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(125, 155, 42, 4, 34, 188, 90, 107, 70, 171): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(146, 73, 106, 67, 5, 33, 128, 144, 49, 189): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(163, 59, 96, 183, 77, 6, 32, 54, 152, 114): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(176, 142, 154, 46, 110, 55, 7, 31, 134, 92): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(185, 86, 75, 170, 50, 115, 162, 8, 30, 69): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Ta = Array(190, 178, 131, 117, 148, 40, 57, 82, 9, 29): i = i + 1
    For j = 1 To 10: Tb(i, j) = Ta(j - 1): Next j
    Erase Ta
    
    Randomize
    
    'mélange colonnes & lignes
    For k = 1 To 2
        ReDim Tc(1 To 10)
        For i = 1 To 10
            Do
                j = Int(10 * Rnd) + 1
            Loop Until Tc(j) = 0
            Tc(j) = i
        Next i
        If k = 1 Then
            ReDim Td(1 To 10, 1 To 10)
            For i = 1 To 10: For j = 1 To 10
                Td(i, j) = Tb(i, Tc(j))
            Next j, i
        Else
            For i = 1 To 10: For j = 1 To 10
                Tb(i, j) = Td(Tc(i), j)
            Next j, i
            Erase Tc: Erase Td
        End If
    Next k
    
    'grille (numéros)
    ReDim Tc(1 To 10, 1 To 10, 1 To 2)
    For i = 1 To 10: For j = 1 To 10
        Td = CombinNthTab(20, 2, Tb(i, j))
        For k = 1 To 2
            Tc(i, j, k) = Td(k)
    Next k, j, i
    Erase Tb: Erase Td
    
    'mélange numéros
    ReDim Tb(1 To 20)
    For i = 1 To 20
        Do
            j = Int(20 * Rnd) + 1
        Loop Until Tb(j) = 0
        Tb(j) = i
    Next i
    
    'écritures
    ReDim Te(1 To 20)
    For i = 1 To 20: Te(i) = Cells(i + 1, 1): Next i
    For i = 1 To 10: For j = 1 To 10: For k = 1 To 2
        Cells(i + 3, 2 * (j - 1) + 3 + k) = Te(Tb(Tc(i, j, k)))
    Next k, j, i
    Erase Tb: Erase Tc: Erase Te
    Cells.EntireColumn.AutoFit
End Sub
Function CombinNthTab(ByVal a&, ByVal b&, ByVal n&) As Long()
    Dim Tb&(), i&, x&, d&
    ReDim Tb(b)
    Do
        d = d + 1: x = 0
        For i = a - 1 - Tb(d - 1) To b - d Step -1
            x = x + CombinNb(i, b - d)
            If Not n > x Then Exit For
        Next i
        Tb(d) = a - i
        n = n - (x - CombinNb(i, b - d))
    Loop Until d = b
    CombinNthTab = Tb
End Function
Function CombinNb(ByVal a&, ByVal b&) As Double
    Dim c&
    c = a - b
    If c = 0 Then
        CombinNb = 1
    Else
        If b < c Then c = b
        CombinNb = Factorielle(a, c) / Factorielle(c)
    End If
End Function
Function Factorielle(ByVal Lg&, Optional NbIter) As Double
    Dim i&, n&
    If Not IsMissing(NbIter) Then n = CLng(NbIter) Else n = Lg
    Factorielle = 1
    If Lg <> 0 Then
        For i = 0 To n - 1: Factorielle = Factorielle * (Lg - i): Next i
    End If
End Function

Effectuez une recherche sur Excel Downloads...

Tirage au sort avec contraintes

baboo1er

XLDnaute Nouveau

Pièces jointes

Dranreb

XLDnaute Barbatruc

baboo1er

XLDnaute Nouveau

Dranreb

XLDnaute Barbatruc

KenDev

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

KenDev

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

KenDev

XLDnaute Impliqué

Dranreb

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

KenDev

XLDnaute Impliqué

KenDev

XLDnaute Impliqué

Pièces jointes

Discussions similaires

Nous accordons de l'importance à votre vie privée