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
 

Fichiers joints

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @phil77515 et bienvenue sur XLD :)

J'ai tenté un truc mais je n'y ai pas mis toute l'énergie que peut-être j'aurais du y mettre.

C'est pourquoi, j'ai un peu modifié le principe:
  • on n'a qu'un seul bouton pour lancer le tirage
  • on effectue les tirages des quatre tours en une seule fois (noms et gages)
  • quand on double-clique sur une cellule contenant un gage, on change le gage cette cellule
Suivant le hasard des tirages, on peut ne pas aboutir à un tirage valable (c'est à dire sans doublons de binômes). La macro va tenter de relancer plusieurs fois le processus. La barre de statut (en bas à gauche) affiche où on en est des essais successifs)

Dans le module de la feuille "tirage au sort" (c'est d'ailleurs dans ce module que se trouve tout le code) figurent deux constantes que vous pouvez modifier:
  • Const MaxDuree qui est le temps maximum (temps en seconde) autorisé pour un seul tirage
  • Const MaxEssai qui est le nombre de tirage maximum à tenter au delà duquel on a un échec des tirages
  • Ces constantes peuvent être modifiées
Si on est face à un échec, relancer un jeu de tirage. Je suis toujours arrivé à un succès en moins de trois jeu de tirage.

nota 1: Ne pas multiplier les incompatibilités dans le tableau "Equipe". En effet, plus vous aurez d'incompatibilités, plus vous aurez de chance d'aboutir à des jeux de tirages infructueux.
nota 2: Le tableau "Equipe" doit être propre. Il doit avoir exactement le nombre de lignes et colonnes nécessaires. Il ne doit pas comporter de lignes ou colonne sans nom de femme ou d'homme.


Le code dans le module de la feuille "tirage au sort":
VB:
Option Explicit
Const MaxDuree = 3   'temps en seconde max pour un tirage
Const MaxEssai = 10  'nombre de tirage max à tenter
Dim Echec As Boolean

Sub Tirages()
Dim i&
   For i = 1 To MaxEssai
      Application.StatusBar = "Essai n° " & i & "  sur " & MaxEssai
      Echec = False
      UnTirage
      If Not Echec Then    '
         MsgBox "Tirage réussi."
         Application.StatusBar = False
         Exit Sub
      End If
   Next i
   MsgBox "Tirages infructueux. Veuillez relancer un autre tirage."
   Application.StatusBar = False
End Sub

Sub UnTirage()
Dim tEqpe, i&, j&, k&, m&, compatible As Boolean, dico As New Dictionary, tgage, Deb

   'Effacement des précédents résultats
   Sheets("tirage au sort").Range("3:999").ClearContents
   DoEvents
   'Lecture du tableau Equipe
   tEqpe = Sheets("Equipe").Range("a1").CurrentRegion
   'création tableau Homme
   ReDim tHom(1 To UBound(tEqpe) - 1)
   For i = 2 To UBound(tEqpe): tHom(i - 1) = tEqpe(i, 2): Next
   'création tableau Femme
   ReDim tFem(1 To UBound(tEqpe, 2) - 2)
   For j = 3 To UBound(tEqpe, 2): tFem(j - 2) = tEqpe(1, j): Next

   '---------------  Les quatre tirages des hommes
   Randomize: dico.CompareMode = TextCompare
   Deb = Timer
   For k = 1 To 4
      dico.RemoveAll
      'création du tableau des tirées au sort Homme en tenant compte des X
      'et des binômes déjà utilisés
      ReDim tiragehom(1 To UBound(tFem), 1 To 1)
      For i = 1 To UBound(tFem)
         compatible = False
         Do
            If Timer - Deb > MaxDuree Then
               Echec = True
               Exit Sub
            End If
            'on tire un homme au hasard (m est son rang)
            m = 1 + Int(Rnd * UBound(tHom))
            'on vérifie si compatible avec la femme de rang i
            compatible = tEqpe(m + 1, i + 2) <> "X"
            If compatible Then
               If Not dico.Exists(CStr(m)) Then
                  dico.Add CStr(m), ""
                  tiragehom(i, 1) = tEqpe(m + 1, 2)
                  tEqpe(m + 1, i + 2) = "X"
               Else
                  compatible = False
               End If
            End If
         Loop Until compatible
      Next i
      Sheets("tirage au sort").Range("A3").Offset(, 4 * (k - 1)).Resize(UBound(tFem)) = Application.Transpose(tFem)
      Sheets("tirage au sort").Range("B3").Offset(, 4 * (k - 1)).Resize(UBound(tFem)) = tiragehom
   Next k

   '---------------  tirage au sort des gages
   'lecture du tableau des gages
   tgage = Sheets("gages").Range("a1").CurrentRegion
   For k = 1 To 4
      For i = 1 To UBound(tFem)
         m = 1 + Int(Rnd * UBound(tgage))
         Cells(2 + i, 3 + 4 * (k - 1)) = tgage(m, 2)
      Next i
   Next k
   Rows(3).Resize(UBound(tFem)).RowHeight = 10
   Rows(3).Resize(UBound(tFem)).AutoFit
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim tgage, oldGage, newGage, n&

   If Not Intersect(Target, Range("c:c,g:g,k:k,o:o")) Is Nothing Then
      If Target.Row >= 3 Then
         If Cells(Target.Row, "a") <> "" And Cells(Target.Row, "b") <> "" Then
            oldGage = Cells(Target.Row, "c")
            'lecture du tableau des gages
            tgage = Sheets("gages").Range("a1").CurrentRegion
            Randomize
            Do
               newGage = tgage(1 + Int(Rnd * UBound(tgage)), 2)
            Loop Until newGage <> oldGage
            Target = newGage
            Cancel = True
         End If
      End If
   End If
End Sub
 

Fichiers joints

Dernière édition:

phil77515

XLDnaute Nouveau
bonjour
un grand merci pour votre aide , j'ai de mon cote préparé un systeme qui a force de fonction fini par fonctionner plus ou moins. car c'est un choix en cascade et comme le prog ne ait pas une analyse de l'ensemble des contraintes , son premier choix et déterminant pour la suite et il arrive qu'a la fin une femme ne soit pas associée car la condition ne le permet pas

la possibilité pour un coupe de change son gage est dans limage de lapin up , 3 boutons et le 4eme en bas a gauche pour ranger

mais c'est pas encore cela , car il faut pour les tours suivant tenir compte aussi qu'un binôme ne doit pas se refaire , la ca devient tres complique avec mes fonctions

je me penche sur ta macro

avec mes plus vifs remerciements

ci joint fichier en *.txt a renommer en XX.rar car l’envoi de fichier compresse n'est pas autorise
 

Fichiers joints

phil77515

XLDnaute Nouveau
rebonjour "mapomme"
je viens de voir c'est super , seul pb si on retire des noms cela ne fonctionne plus

je vais regarder et essaye de comprendre la macro
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

La macro fonctionne bien si on respecte les conditions citées dans mon premier message!
A savoir:
nota 2: Le tableau "Equipe" doit être propre. Il doit avoir exactement le nombre de lignes et colonnes nécessaires. Il ne doit pas comporter de lignes ou colonne sans nom de femme ou d'homme.
Donc si vous retirez un participant (vous supprimer sa ligne) et si vous supprimez une participante vous supprimez sa colonne.
 

phil77515

XLDnaute Nouveau
Bonsoir
pour "ma-pomme" , un grand merci je vais donc faire un fichier par nb de couple. car je suppose que si je supprime dans l'original , ca sera complique apres e rajouter des lines , enfin je vais essayre

pour Danreb , je teste cela demain

merci vous deux
Phil
 

phil77515

XLDnaute Nouveau
c'est impec danreb ; merci

comment fait t'on pour que les tirages soit en ligne et pas en colonne
je veux dire que le second tour soit en dessous du premier et le 3eme a la suite etc
 

Dranreb

XLDnaute Barbatruc
Oh ben ça touche la mise en forme tout à la fin du TRés (tableau résultant) pour chaque élément il faut calculer sa ligne et colonne différemment en fonction de L et M.
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @phil77515 :), @Dranreb :),

Ma dernière mouture avec un code entièrement repensé:
  • globalement beaucoup plus rapide (pas tant pour trouver une solution mais surtout pour éliminer les impasses)
  • le tableau Equipe permet d'avoir des lignes ou colonnes sans homme ou femme
  • avec un bouton pour confirmer que la solution ne comporte pas de binômes en doublon
  • avec un bouton pour confirmer que la solution ne comporte pas de binômes dont les membres sont incompatibles entre eux
 

Fichiers joints

Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonsoir.
Mais, mapomme, as tu réalisé que mon algorithme du poste #8 ne se permet pas de produire des binômes en double ni interdits ?
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir Dranreb

Mais, mapomme, as tu réalisé que mon algorithme du poste #8 ne se permet pas de produire des binômes en double ni interdits ?
Le mien théoriquement non plus. Les boutons, c'est juste pour confirmer.

C'est bizarre, selon les tirages, j'en trouve dans ton fichier du post #8.
Mais j'ai sans doute merdoyé en le testant.
J'ai testé avec le fichier joint issu du post #8...
(même tableau équipe que mon fichier du post #14)
 

Fichiers joints

Dernière édition:

Dranreb

XLDnaute Barbatruc
C'est exact, il y a des incompatibles. Désolé.
Merci @mapomme de l'avoir signalé.
Le problème semble résolu en remettant des instructions à leur place logique à la fin de la Sub Trouvé. :
VB:
Private Function Trouvé(ByVal Niv As Long) As Boolean
   Dim M As Long, L As Long, LAt As ListeAléat, P&, J&
   M = Niv \ NbEQu + 1: If M > 4 Then Trouvé = True: Exit Function
   Set LAt = TAléa(M): L = Niv Mod NbEQu + 1
   P = 0: Do: P = P + 1: J = LAt.Aléat(P): If J = 0 Then Exit Function
      If TLibre(L, J) Then
         LAt.Supprimer J: TLibre(L, J) = False
         Trouvé = Trouvé(Niv + 1)
         If Trouvé Then TTir(M, L) = J: Exit Function
         LAt.Remettre J, P: TLibre(L, J) = True: End If
      Loop
   End Function
Il m'avait cependant semblé que cela n'avait pas d'incidence sur le résultat, parce que si on fait Remettre J, P alors qu'il y est déjà ça ne changeait, rien pas plus que si on mettait TLibre(L, J) = True alors qu'il y est déjà. J'ai du très mal raisonner, c'est sûr. En tout cas comme indiqué plus haut c'est maintenant correct.
Prière à @phil77515 de rectifier aussi.
 

phil77515

XLDnaute Nouveau
bonjour à vous deux
merci pour votre opiniâtreté


j'ai voulu de mon cote pousser les limites , a savoir definir pour un infividu le fait de ne vouloir aller qu'avec 2 possibilités

j'ai teste les deux

pour mapomme , la macro échoué

et pour celle de Danreb apres intégration du dernier code , le système plante

et affiche "erreur automation"

je savais que ca n'allait pas être évident , meme avec le solveur excel , ca atteint ses limites
et encore , pour aller plus loin il faudrait que pour les tours suivants les personne ne se retrouvent pas à nouveau et avec un gage deja fait ...

mais la ; c'est l'horreur

bien a vous deux

moi avec mes fonction et le macros , ca déconne aussi , puisque c'est un tirage au sort en cascade
donc si le dernière personne reste avec les non affectation des permiers binomes et si la condition "x"est réalisée ca affiche rien

bien à vous deux
phil
 

Fichiers joints

Dranreb

XLDnaute Barbatruc
Bonjour.
Le Temp.xlsm ne pouvait pas aboutir en l'état car il y avait moins de 4 partenaires possibles pour lowen
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Sous réserve qu'il y ait désormais au moins 4 partenaires possibles pour chacun, la version qui évite une réattribution d'un même gage.
Au contraire de la version précédente, un même gage pourra cependant être attribué plusieurs fois au cours d'un même tour.
À tester soigneusement pour éviter de passer à coté d'un nouveau bogue insoupçonné.

Pièce sointe supprimée parce qu'il y avait effectivement encore un bogue …
 
Dernière édition:

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas