XL 2010 Tirage au sort d'équipes avec conditions en VBA

[Calou37]

Bonjour à toutes et à tous,
Ceci est mon premier post car depuis très longtemps j'arrive à me débrouiller en fouillant un peu partout.
Je ne suis pas développeur (malgré avec fait quelques formations) mais un grand bidouilleur en récupérant des applis à droite et à gauche et en les adaptant à mes besoins.
Mais là je tombe sur un os où je n'arrive pas à me dépatouiller.
Je suis sur un projet de passer de graphiques papiers pour l'organisation de concours de pétanque à du numérique. Il en existe beaucoup disponibles sur le net mais aucun ne correspond à notre formule qui est un graphique continu, c'est à dire qu'il n'y a pas d'éliminations, le nombre de parties est en fonction du nombre d'équipes, les gagnants se rencontrent ainsi que les perdants.
Mon soucis majeur est le premier tirage au sort pour donc la première rencontre, où selon les équipes inscrites (déjà formées) certaines sont dites Homogènes (les 2 joueurs(ses) sont du même club et d'autres non Homogènes. Puis selon le nombre d'équipes inscrites, on arrondi ce nombre pour avoir ou 8, 16, 32, 64 ou 128 équipes en ajoutant des Blancs pour compléter.
J'ai deux conditions :

1) 2 équipes du même club ne peuvent se rencontrer au premier tour​

2) 1 équipe NH (non Homogène) ne peut rencontrer un Blanc (sauf si plus de NH que d'équipes Homogène)​

Privilégier les équipes Homogènes (Clubs) pour attribuer des Blancs​

Je vous joints un fichier exemple de ce que j'aimerais obtenir, il n'y aucune macro afin de partir de 0. Des explications sont sur le fichier.

Je vous remercie beaucoup d'avance de votre aide, avec nos conditions actuelles de confinement, on s'occupe comme on peut mais surtout :

Respecter ce confinement, Restez chez vous et Prenez soin de vous et de vos proches​

 

[Pounet95]

Bonjour,
Avant même de tenter quelque chose, TRES IMPORTANT :
ne mettre en pièce jointe que des données ANONYMES !!!!

 

[Calou37]

Bonjour,
Merci de vos recommandations, mais bien que les données mises dans le fichier ne sont pas confidentielles, je joins à nouveau mon fichier avec des données purement fictives.
Merci encore

 

[Pounet95]

Bonsoir,
Un petit peu de prise de tête par moments, mais j'ai, je pense, réussi à "pondre" quelque chose.
A tester et vérifier et ne pas hésiter à revenir si problème.
Pounet95, bricolo aussi en VBA
Editer : modifié pour prise en compte nombre impair d'équipes inscrites d'où dernière rencontre du tour 1 gagnée d'office

 

[Calou37]

Bonsoir,
Je vais de ce pas tester, avant tout un grand merci déjà pour la réactivité et pour le travail.
Je vous tiens au courant
Pascal

 

[Calou37]

Bonsoir,

Je viens donc de tester et je vois sur le tirage déjà effectué les conditions ne sont pas remplis.
Il y a 2 équipes du même club qui se rencontrent
Il y a 2 blancs qui se rencontrent
il y a des équipes non homogènes qui ont des blancs (priorité aux équipes homogènes pour rencontrer des blancs).
Du coup, je me suis dit que c'était surement un test et donc j'ai voulu refaire le tirage sauf que ça a planté.

Je conçois que c'est assez prise de tête et c'est bien pour cela que je fais appel
Prenez bien soin de vous
Pascal

 

[Pounet95]

Bonsoir,
J'ai l'impression que le fichier testé n'est pas le dernier envoyé.
C'est le fait de voir encore des Blanc qui me chagrine. Dans l'import il me semble bien les ignorer d'une part, et pour les rencontres je teste bien si les équipes sont de clubs différents.

    ligBD = 4
    With shBD
       [B] Do While .Cells(ligBD, 4) <> "Blanc"       'Les blancs sont ignorés[/B]
            Cells(lig, 1) = .Cells(ligBD, 1)
            Cells(lig, 2) = .Cells(ligBD, 2)
            Cells(lig, 3) = .Cells(ligBD, 2) & " " & .Cells(ligBD, 4) & " " & Left(.Cells(ligBD, 5), 1) & " - " _
                & .Cells(ligBD, 8) & " " & Left(.Cells(ligBD, 9), 1)
            ligBD = ligBD + 1
            lig = lig + 1
        Loop
        'Cas nombre impair d'inscrits
        If Cells(ligBD, 1) Mod 2 > 0 Then
            [B][I]'Ajoute une équipe Blanc     normalement la seule si nombre équipes est impair[/I][/B]
            Cells(lig, 1) = .Cells(ligBD, 1)
            Cells(lig, 2) = .Cells(ligBD, 2)
            Cells(lig, 3) = .Cells(ligBD, 2) & " " & .Cells(ligBD, 4) & " " & Left(.Cells(ligBD, 5), 1) & " - " _
                & .Cells(ligBD, 8) & " " & Left(.Cells(ligBD, 9), 1)
        End If
    End With

    numLig = 6
    For i = 6 To derLig Step 2
        Range("H" & numLig) = Range("C" & i)
        If Range("B" & i + 1) = Range("B" & i) Then   '   ici on vérifie que l'adversaire n'est pas du          même club et si c'est le cas on le déplace en fin de liste
            Range("A" & i + 1 & ":E" & i + 1).Select
            Selection.Cut
            Range("A" & derLig + 1).Insert Shift:=xlDown
        End If
        Range("J" & numLig).FormulaR1C1 = Range("C" & i + 1)
        numLig = numLig + 1
    Next i

 

[Pounet95]

Bonsoir à nouveau
J'ai revu le classeur et fait quelques tests
A priori ça devrait mieux aller, mais sait-on jamais ?

 

[Calou37]

Re Bonsoir,
Merci encore pour ton dévouement mais je vois que tu as enlevé la prise en compte de tous les blancs que j'avais ajouté, en fait c'est une des particularités de nos concours, c'est que nous démarrons toujours avec un nombre d'équipes équivalent à 8 / 16 / 32 / 64 / 128. Si le nombre d'inscrits est inférieur à une de ces valeurs, on rajoute le nombre de blancs nécessaires pour avoir le compte.
Soit mon exemple où il y a 42 équipes d'inscrites, on rajoute donc 22 blancs pour atteindre les 64.
Avec cette condition supplémentaire, c'est là que ça se complique.
Personnellement j'avais essayé en bouclant sur une colonne où je vérifiais si les conditions étaient remplies par un Ok ou NoK, si NoK je recommençais le tirage jusqu'à ce que toutes les lignes soit Ok.
Ça fonctionne relativement bien jusqu'à max 32 équipes, au delà ça plante "Erreur 28" par manque de mémoire pile.
Et je n'ai pas pu ré-essayer ton appli, j'ai tjrs le message d'erreur que je vous ai indiqué en image sur mon post #6
Bonne nuit
Amicalement
Pascal

 

[Pounet95]

Bonjour,
Pour l'erreur 438, je ne comprends pas car il s'agit tout bêtement du code obtenu par l'enregistreur de macro. Je n'arrive pas à le reproduire.
Par contre, sans que je sache pourquoi, j'ai un autre problème quand je fais plusieurs tirages à la suite via le bouton dédié : ça part je ne sais où et je ne peux pas arrêter autrement que "bestialement" avec Alt Ctrl Sup pour atteindre le gestionnaire de programmes et arrêter la tâche.

Concernant les "blanc" , je ne comprends pas trop.
Dans ton exemple , 42 équipes engagées et donc 22 blancs. Cela veut dire que l'on va tirer 32 rencontres avec comme possibilités extrèmes que :
- 10 rencontres opposeront 2 équipes réelles, 22 rencontres opposeront une équipe réelle à "blanc",
- 21 rencontres opposeront 2 équipes réelles et les 11 autres les "blanc" entre eux

Tu précises aussi qu'il n'y a pas d'éliminations. Cela veut dire que chacune des équipes doit disputer le même nombre de rencontres et que l'équipe gagnante sera celle qui aura le plus de points en fonction des victoires, des scores,etc.
Ou bien un peu à la façon des Coupes du Monde ou d'Europe de Foot, une phase de groupes puis éliminatoires ?

Je vais déjà voir pourquoi j'ai ce départ en "vrille" ici. Si tu peux m'en préciser d'avantage sur l'erreur ( exécution pas à pas ou non, On error activé ou pas, etc), je suis preneur.

A suivre
Claude
PS: j'aimerais mieux être tutoyé, ça n'enlève en rien le respect, à mon avis.

 

[Calou37]

Bonjour Claude,
Tu as tout compris sur le fonctionnement de nos concours, c'est exactement ce que tu as décrit :
Pas d'éliminations, tout le monde joue le même nombre de parties, Ci-dessous un Schéma de nos graphiques (j'aurais dû commencer par ça)

Je n'ai pas encore eu le temps de voir pour cette erreur "438", j'y regarde dans la journée.
A plus tard et pas de problème pour le tutoiement, bien au contraire.
Pascal

 

[Pounet95]

Re Bonjour,
Je crois que ça pourrait être une solution.
Ca répond aux critères pas de rencontres entre équipes d'un même club, priorité à ces équipes de "jouer un blanc".
Reste à tester
Bon courage
Claude

 

[Calou37]

Bonsoir Claude,
Encore merci pour tous les efforts que tu fais malheureusement je ne peux tjrs pas tester avec ce problème d'erreur "438", j'ai passé un bon moment dessus et je n'arrive vraiment pas à régler ce problème.
Peut-être est-ce dû à la version d'office ? Je suis habituellement sur une 2010, du coup j'ai essayé avec une 2016 mais pareil, tjrs ce même message qui me bloque pour pouvoir tester.
C'est gênant surtout que j'aimerai vraiment voir ce que cela donne.
Si tu as une solution, bien entendu je suis preneur.
Amicalement
Pascal

 

[Calou37]

Re Bonsoir Claude,

Ça y est j'ai enfin trouvé le pourquoi ça planté.
C'était sur 2 lignes de tri ".Sort.SortFields.Add", j'ai du retirer le "2" derrière le Add :

1. 'Tri par club de façon à mettre les YNH et ZBL en fin de liste
   derLig = Cells(10000, 1).End(xlUp).Row ActiveWorkbook.Worksheets("Tirage").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Tirage").Sort.SortFields.Add2 Key:=Range("B6:B" & derLig) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

2. 'Trier sur le tirage aléatoire​

ActiveWorkbook.Worksheets("Tirage").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tirage").Sort.SortFields.Add2 Key:=Range("E6:E" & ligYHN) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

Il ne me reste plus qu'à mettre cela en place sur mon fichier d'origine et faire quelques tests avec différentes configurations.
Un Grand, Grand merci pour ton travail
Je laisse cette discussion encore un peu active le temps de mes tests
Amicalement
Pascal

 

[Pounet95]

Bonjour,
Content que tu aies trouvé l'origine du bug. Comme je l'ai précisé, chez moi, avec Excel 2016, ça ne le fait pas. En consultant l'aide Microsoft, il existe bien 2 méthodes Add pour l'objet Sortfields. Je n'ai pas creusé la différence entre les 2. Est-ce que c'est dû aux versions différentes d'Excel ????
Le principal est que ça fonctionne.
J'ai bien compris le principe de "tout le monde joue le même nombre de rencontres". Mais est-ce vrai car si j'en crois les tests avec les données actuelles, avec 22 BL, il y a autant de rencontres où l'adversaire n'existe pas ! Il y a alors 22 qualifiés d'office ......... sans jouer !
Info : sympa le blog du club où j'ai pu voir qu'il y avait des compétitions quasiment tous les weekend, mais annulées sûrement , hélas.
Bons test
Claude