Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Aide pour creer une macro pechue

phil77515

XLDnaute Nouveau
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
 

Pièces jointes

  • JEU TIRAGE SORT.xlsm
    31.8 KB · Affichages: 62

phil77515

XLDnaute Nouveau
bonjour danreb
j'"e'spere que ca va avec cette situation deplorable
 

Pièces jointes

  • Temp (4).xlsm
    55.4 KB · Affichages: 2

phil77515

XLDnaute Nouveau
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
 

Pièces jointes

  • phil77515- JEU TIRAGE SORT- v4a.xlsm
    36.2 KB · Affichages: 4

Dranreb

XLDnaute Barbatruc
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).
 
Dernière édition:

phil77515

XLDnaute Nouveau
Ç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
 

Pièces jointes

  • adobe.xlsm
    55.5 KB · Affichages: 3

Dranreb

XLDnaute Barbatruc
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.
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
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)
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
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.
 

Pièces jointes

  • Temp.xlsm
    62.5 KB · Affichages: 4

Dranreb

XLDnaute Barbatruc
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 :
VB:
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

XLDnaute Nouveau
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
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…