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

P

Pounet95

XLDnaute Occasionnel

• 9 Avril 2020

• #2

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

 

Vote positif 0 Vote négatif

C

Calou37

XLDnaute Nouveau

• 9 Avril 2020

• #3

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

 

Pièces jointes

• ProjetTirageConcoursPetanque.xlsm

  47.7 KB · Affichages: 21

Vote positif 0 Vote négatif

P

Pounet95

XLDnaute Occasionnel

• 9 Avril 2020

• #4

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

 

Pièces jointes

• ProjetTirageConcoursPetanque Pounet.xlsm

  52.6 KB · Affichages: 30

Dernière édition: 9 Avril 2020

Vote positif 0 Vote négatif

C

Calou37

XLDnaute Nouveau

• 9 Avril 2020

• #5

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

 

Vote positif 0 Vote négatif

C

Calou37

XLDnaute Nouveau

• 9 Avril 2020

• #6

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

 

Pièces jointes

• ProjetTirageConcoursPetanque Pounet.xlsm

  82 KB · Affichages: 9

Vote positif 0 Vote négatif

P

Pounet95

XLDnaute Occasionnel

• 9 Avril 2020

• #7

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.

VB:

    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

Code:

    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

 

Vote positif 0 Vote négatif

P

Pounet95

XLDnaute Occasionnel

• 9 Avril 2020

• #8

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

 

Pièces jointes

• Concours Pétanque Tirage Parties 1.xlsm

  77.1 KB · Affichages: 32

Vote positif 0 Vote négatif

C

Calou37

XLDnaute Nouveau

• 9 Avril 2020

• #9

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

 

Vote positif 0 Vote négatif

P

Pounet95

XLDnaute Occasionnel

• 10 Avril 2020

• #10

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.

 

Vote positif 0 Vote négatif

C

Calou37

XLDnaute Nouveau

• 10 Avril 2020

• #11

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

 

Vote positif 0 Vote négatif

P

Pounet95

XLDnaute Occasionnel

• 10 Avril 2020

• #12

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

 

Pièces jointes

• Projet 3 TirageConcoursPetanque.xlsm

  173.7 KB · Affichages: 57

Vote positif 0 Vote négatif

C

Calou37

XLDnaute Nouveau

• 10 Avril 2020

• #13

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

 

Vote positif 0 Vote négatif

C

Calou37

XLDnaute Nouveau

• 11 Avril 2020

• #14

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

 

Vote positif 0 Vote négatif

P

Pounet95

XLDnaute Occasionnel

• 11 Avril 2020

• #15

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

 

Vote positif 0 Vote négatif