XL 2016 Aide pour creer une macro pechue

[phil77515]

bonjour

je souhaiterais avoir de l'aide pour créer un petit sous excel

au premier tour
il s'agit de composer des binômes en fonction de critères Puis de leur attribuer un gage

au second tour
toujours pareil sauf que les binômes doivent changer

idem au 3eme et 4eme tour

j'ai prépare un fichier avec déjà des éléments mais mes limites sont atteintes

merci de votre aide

 

[phil77515]

bonjour danreb

j'"e'spere que ca va avec cette situation deplorable

je reviens sur mon petit jeu car avec le confinement on se remets sur les appli
j'ai redui a 4 couple et la ca coince car il dit qu'il ne peut pas faire 4 tours comptetenu qu'il y a 3 participants

il faudrait donc que si le nombre de couple est < à 4 , il mette un tirage vide pour le 4 eme

bien a toi merci

 

[phil77515]

Bonjour @phil77515 , @Dranreb ,

Une dernière version qui tente:

• de ne pas affecter un même gage à un participant pour l'ensemble des 4 tirages
• de ne pas affecter deux fois le même gage lors d'un tour

bonjour ma pomme
j'espere que tout va
idem que pour reponse a danreb , en dessous de 4 couples il faut que le 4 eme tirage soit vide
merci

 

[phil77515]

bonjour ma pomme
j'espere que tout va
idem que pour reponse a danreb , en dessous de 4 couples il faut que le 4 eme tirage soit vide
merci

oui mais la il tourne en rond , car effectivement si 4 tirage et 3 possinilite , le dernier tirage ne peut remplir la condition ; et donc il arrive sur infructueux

 

[Dranreb]

Bonjour.
Pareil pour moi. Même s'il n'y a aucune incompatibilité demandée, s'ils ne sont que 4 il ne peuvent chacun en rencontrer que 3 autres, donc pas de quoi faire un 4ème tour.
Édition: C'est plus compliqué. J'ai dû mal à replonger dedans. C'est peut être plutôt parce qu'il n'y a pas assez de rencontres multiples expressément autorisées, c'est à dire pas assez de cases dans la grille avec un nombre > 1 (une case vide est assumée = 1).

 

[phil77515]

re
ce qu'il faudrait c'est pouvoir donner le nombre de tirages à realiser au debut ou avec un Nbval des hommes
si 3 couples = 2 tirages
si 4 couples = 3 ...............
si 5 > 20 couples 4 tirages

 

[phil77515]

bonjour

je suis arrive a bidouille

 

[Dranreb]

Ça ne passe pas si vous mettez 2 partout dans la grille ?

 

[phil77515]

Ça ne passe pas si vous mettez 2 partout dans la grille ?

je ne comprends pas
meme en corsant les incompatibilites , on arrive à 1 tirage

par contre un conseil

j'ai mis un gif anime qui est place dans un userform que j'ai appelé "Merci_de_patienter"
je voudrais le faire tourner durant l'excution de la macro quand on est 10 couples avec plein d'incompatibilite ,


soit j'ai une image figée t la macro tourne
ou alors avec d'autres codes une image qui tourne mais qui fige la macro

ci joint fichier avec 1 grille et 2 partpout

 

[Dranreb]

La grille permet de signaler des incompatibilité par une lettre, mais elle permet aussi, au contraire, d'autoriser plusieurs fois la rencontre de deux personnes
Dans mon fichier d'origine Il y avait déjà un UFmVisu qui montrait bien plus précisément l'activité du tirage en cours, non ?
Mais je vois que ce n'est pas ma solution que vous avez finalement choisi de suivre.

 

[phil77515]

voila voter dernier fichier

 

[Dranreb]

Bonsoir.
Je n'avais pas vu votre dernier poste.
Mais j'ai fait l'essai: en mettant partout 2 dans la grille sauf sur la diagonale, mon classeur trouve bien une solution pour 4 tours avec 3 couples. (Il n'y a plus le message car chaque participant a 2 × 2 soit 4 rencontres possibles)

 

[Dranreb]

Je joins quand même une version sans message d'erreur, qui ajuste le nombre de manches au nombre de rencontres possibles du participant qui en permet le moins, sans toutefois dépasser 4.

 

[phil77515]

merci c'est super , j'aiteste , c'est ultra rapide

j'etudie vos codes , merci

 

[Dranreb]

Bonjour.
Je pense avoir trouvé une anomalie dans ma Function Trouvé. Il me semble qu'on n'en sort pas assez tôt quand il fixe la dernière paire. Étonnant que ça ne l'empêche pas de finir. Je l'ai corrigée comme suit :

Private Function Trouvé(ByVal Niv As Long) As Boolean
   Dim M As Long, LAtJ As ListeAléat, PJ As Long, J As Long, _
       L As Long, LAtG As ListeAléat, PG As Long, G As Long
   UFmVisu.Montre Niv / NivMax
   M = Niv \ NbEQu + 1: L = Niv Mod NbEQu + 1: Set LAtJ = TLAtJ(M): Set LAtG = TLAtG(M)
   If L = 1 And M > 1 And NbGages >= 2 * NbEQu Then
      LAtG.Init NbGages: For L = 1 To NbEQu: LAtG.Supprimer TTir(M - 1, L, 2): Next L
      L = Niv Mod NbEQu + 1: End If
   Do: If UFmVisu.Abandon Then Exit Function
      PJ = PJ + 1: J = LAtJ.Aléat(PJ): If J = 0 Then Exit Function
      If TNbRenc(L, J) Then
         PG = 0: Do: PG = PG + 1: G = LAtG.Aléat(PG): If G = 0 Then Exit Function
            Loop While TGAttr(1, L, G) Or TGAttr(2, J, G)
         LAtJ.Supprimer J: TNbRenc(L, J) = TNbRenc(L, J) - 1: LAtG.Supprimer G: TGAttr(1, L, G) = True: TGAttr(2, J, G) = True
         TTir(M, L, 1) = J: TTir(M, L, 2) = G
         If Niv >= NivMax Then Trouvé = True: Exit Function
         Trouvé = Trouvé(Niv + 1): If Trouvé Then Exit Function
         LAtJ.Remettre J, PJ: TNbRenc(L, J) = TNbRenc(L, J) + 1: LAtG.Remettre G, PG: TGAttr(1, L, G) = False: TGAttr(2, J, G) = False
         End If
      Loop
   End Function

i

 

[phil77515]

bonjour danreb

merci , j'ai mis a jour

par contre je ne trouve pas de fonction timer pour UFmVisu , j'ai vu durééenclair mais ca doit etre le calcul
car je voudrais reduire sa duree de vision apres le resulat

sinon est ce la dedans

Private Sub Visu(ByVal S As Double)
LabFait.Width = SMin * LabTout.Width
LabPbl1.Left = LabFait.Left + LabFait.Width: LabPbl1.Width = (S - SMin) * LabTout.Width
LabPbl2.Left = LabPbl1.Left + LabPbl1.Width: LabPbl2.Width = (SMax - S) * LabTout.Width
End Sub

merci