Macro difficile à adapter

Question

Je reviens vers vous car je n'arrive pas à adapter une macro: C'est la macro "Sub Poules()" encadrée de '0000000000000000 pour la repérer dans le VBA de la feuille 3. Elle se lance par le bouton "Poules de la feuille 3, est me propose 2 choix de tirages: - Le premier donne le résultat afficher à l'écran, ce qui me convient très bien, puisque je veux effectivement des poues de 4 équipes, mais l'intitulé de la proposition ne correspond pas du tout... - Le second tirage ne m'intéresse pas du tout. J'aimerais que, si le nombre d'équipes est bien un multiple de 4, le tirage se fasse directement. sinon, que le tirage se fasse en fonction du nombre d'équipes inscrites: Exemple 1: 22 équipes = 4 poules de 4 équipes et 2 de 3 équipes Exemple 2: 26 équipes = 5 poules de 4 équipes et 1 de 3 équipes Et n'afficher une MsgBox que si aucune de ces solutions n'est possible, exemple 21 ou 25 équipes inscrites. Si quelqu'un avait la gentillesse de m'aider à réaliser ça, ce serait le bonheur pour moi. Merci de votre aide. mon fichier joint...

ExcelCoreGame · Answer

Il y a pas mal de ligne passée en commentaire dis donc ^^ Et les participants sont de légende Je regarde ça demain soir en détail si d'ici la personne ne t'a aidé, cela devrait ne pas poser de gros soucis je pense vu la modif que tu veux faire ECG...

ExcelCoreGame · Answer

Y a des boucles dans tous les sens héhé

Par contre si je pige bien, tu fais des poules en prenant les équipes dans l'ordre, tu ne voudrais pas plutot tirer au hasard?

Edit: ou quand tu fais les équipes si les gens s'inscrivent 1 par 1 et pas en équipes ?

Edit2: heu et si un jour tu as 9 équipes ou 11? tu veux pas pouvoir le gérer?

ECG

Curulis · Answer

J'avais déjà regardé et ce n'est guère plus évident maintenant... ExcelCoreGame a raison de vouloir clarifier les choses. comment formes-tu tes équipes de 2? Je t'avoue n'avoir rien compris à tes Unicode... j'imagine qu'il faut tirer les poules au hasard? pourquoi tant de MsgBox? Un cas se décide selon le nombre d'équipes, non? Pas besoin de tant de discours! les cas soulevé par ExcelCoreGame de 6 ou 9 équipes peut-il être réglé par autant de poules de 3? Bref, clarifie et explique ce que tu veux (à priori évident) ! A+...

ExcelCoreGame · Answer

Comme promis un premier jet de macro pour faire : si un multiple de 4 : X équipe de 4 si 22 équipes : 4 poules de 4 équipes et 2 de 3 équipes si 26 équipes : 5 poules de 4 équipes et 1 de 3 équipes sinon abandon Pour vraiment automatiser tout ça il faut surement jouer avec les modulos ou des if pour trouver le nombre d'équipe de 4 et de 3 pour utiliser toutes les équipes présentes et lancer le boucles For selon ces critères Edit : avec le fichier c'est mieux quand on clique sur "ajouter le fichier" A noter que je réutilise pas mal du code que tu as, personnellement je maitrise peu les offset, j'aurais fait autrement mais ca a l'air de tourner comme ça, après pour remodifier les macros il faudra peut être repartir sur des bases voir carrément faire les équipes et les poules dans la même macro, une étape entre les deux apportes rien je pense ECG...

ExcelCoreGame · Answer

La macro que je t'ai mis juste avant fonctionne dans ta sheet3, il reste juste a gérer les différents cas d'équipes...

ExcelCoreGame · Answer

Oui car j'ai édité mon message en le rajoutant

Sinon j'ai vu que tu as mis 2 fichiers en téléchargement, je regarderais les deux en détails mais dans celui que j'ai (il me semble le dernier) je vois bien pourtant :

Randomize
NbreColB = Int(Rnd * Len(SerieUnicode) + 1)

Donc il y a quand même du Rnd mais bon cela à l'air de marcher niquel tout ça, autant ne pas réinventer la roue si on peut

Pour cela que j'ai repris le code pour faire mon fichier en modifiant un peu

A voir si tu as arrives à faire ce que tu veux par la suite yes

Clair il se fait tard, on reverra ça plus tard ^^

ECG

ExcelCoreGame · Answer

Salut je viens de te modifier le code pour s'adapter au nombre d'équipe:

Sub TIRAGE_POULES()
Dim NbEquipes As Integer
Dim NbPoules As Integer
Dim NbElements As Integer
Dim Tourne As Integer
Dim Boucle As Integer
Dim boucle2 As Integer
Dim STOCK_OFFSET As Integer
Dim i As Integer

NbEquipes = Replace(Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Value, "Equipe ", "")

'si on a une multiple de 4, on utilise pour ca le modulo et on regarde le reste
If NbEquipes Mod (4) = 0 Then
    NbPoules = NbEquipes / 4
    NbElements = NbEquipes / NbPoules
    'Sheets("Feuil3").Range("A2:BB200").ClearContents
    NbPoules = 0
    For Boucle = 1 To NbEquipes Step NbElements
       NbPoules = NbPoules + 1

       'Inscrit verticalement le N° des poule
       Sheets("Feuil3").Range("A1").Offset(Tourne, 0) = "Poule " & NbPoules

    '  Inscrit vertcalement les parties
       Sheets("Feuil3").Range("A3:C" & NbElements + 2).Offset(Tourne - 1, 0) = Sheets("Feuil2").Range("A2:C" & NbElements + 2).Offset(Boucle - 1, 0).Value

       Tourne = Tourne + 7
    Next Boucle

Else
    For i = NbEquipes To 0 Step -1
       'on trouve la combinaison d'équipe de 4 et de 3
        If i Mod (4) = 0 And (NbEquipes - i) Mod (3) = 0 Then
            'on fait les équipes de 4
            NbPoules = 0
            NbElements = 4
            For Boucle = 1 To i / NbElements
               NbPoules = NbPoules + 1

               'Inscrit verticalement le N° des poule
               Sheets("Feuil3").Range("A1").Offset(Tourne, 0) = "Poule " & NbPoules

            '  Inscrit vertcalement les parties
               Sheets("Feuil3").Range("A3:C" & NbElements + 2).Offset(Tourne - 1, 0) = Sheets("Feuil2").Range("A2:C" & NbElements + 2).Offset((Boucle - 1) * 4, 0).Value

               Tourne = Tourne + 7
            Next Boucle

            'le restant des équipes par 3
             NbElements = 3
            STOCK_OFFSET = (Boucle - 1) * 4

            For boucle2 = 1 To (NbEquipes - 4 * (Boucle - 1)) / NbElements
               NbPoules = NbPoules + 1

               'Inscrit verticalement le N° des poule
               Sheets("Feuil3").Range("A1").Offset(Tourne, 0) = "Poule " & NbPoules

            '  Inscrit vertcalement les parties
               Sheets("Feuil3").Range("A3:C" & NbElements + 2).Offset(Tourne - 1, 0) = Sheets("Feuil2").Range("A2:C" & NbElements + 2).Offset(STOCK_OFFSET + (boucle2 - 1) * 3, 0).Value

               Tourne = Tourne + 7
            Next boucle2

            Exit Sub
        End If
    Next

    'si on arrive ici c'est qu'on est pas sorti de la boucle via le exit sub donc on a pas trouvé de solution
     MsgBox "Pas de solution de poules"

End If

Du coup pour 21 équipes cela fait 3 x4 +et 3x3 ; pour 25 équipes, 4x 4 + 3x3

A noter que quand on entre dans le

  If i Mod (4) = 0 And (NbEquipes - i) Mod (3) = 0 Then

j'ai mis un

Exit Sub

dans la boucle

For i = NbEquipes To 0 Step -1

En gros on part donc du max d'équipes inscrites et on regarde le premier set d'équipe multiple de 4 et 3 qu'on trouve pour l'utiliser, dans la macro tu auras donc toujours un max d'équipes de 4 complété par des équipes de 3

On peut imaginer pour reprendre ce que tu voulais avec les msgbox, de toujours calculer toute les combinaisons possible et de demander si cela convient, si oui on fait la macro sinon on va voir la prochaine combinaison.

Voir carrément de faire un autre userform avec une listbox et d'y inscrire toute les combinaisons possible, le joueur selectionne celle qu'il veut et clique sur ok ce qui lance la macro, à toi de voir

ECG

Curulis · Answer

Voilà ton fichier que j'ai complètement remis à ma sauce! Tu as deux cadres de paramétrage : - un cadre pour configurer le nombre d'équipes par poule principale et un nombre d'équipes pour les poules de substitution si le nombre d'équipes n'est pas un multiple parfait. Un clic sur un de ces choix déclenche le calcul de tirage aléatoire de tes poules qui s'affichent sur la même feuille. - un cadre pour configurer le nombre de joueurs par équipe . Les équipes sont alors colorées par groupe, les joueurs restant sans équipe (toujours en bas de tableau) étant colorés différemment. Ici, je pratique en postulant que les équipes se forment dans l'ordre d'affichage dans le tableau des joueurs. Une MsgBox affiche le résultat de la meilleure combinaison de nombre d'équipes par poule. Si c'est impossible, et bien, tu recommences autrement... Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' Dim tDataJ, tDataGR() ' Application.EnableEvents = False ' If Not Intersect(Target, Range("G2:G4")) Is Nothing Then iRow = Target.Row Range("G2:G4").Value = "" Target = "P" iRow = Range("A" &amp; Rows.Count).End(xlUp).Row Range("A2:A" &amp; iRow + 10).Interior.Color = xlNone For x = 2 To iRow Step Target.Offset(0, 1).Value Range("A" &amp; x &amp; ":A" &amp; x + Target.Offset(0, 1).Value - 1).Interior.Color = _ IIf(Range("A" &amp; x).Offset(Target.Offset(0, 1).Value - 1, 0).Value = "", RGB(255, 190, 0), _ IIf(Range("A" &amp; x - 1).Interior.Color = RGB(255, 255, 255), RGB(215, 215, 215), xlNone)) Next Range("A" &amp; iRow + 1 &amp; ":A" &amp; iRow + 10).Interior.Color = xlNone Range("G1").Select End If ' If Not Intersect(Target, Range("C2:C5")) Is Nothing Then iRow = Target.Row Range("C2:C5").Value = "" Target = "P" Range("C1").Select ' iNbJ = Range("A" &amp; Rows.Count).End(xlUp).Row - 1 'nbre de joueurs Range("B:B").Value = 0 tDataJ = Range("A2:B" &amp; iNbJ + 1).Value iEq = Range("G2:G4").Find(what:="P", lookat:=xlWhole).Offset(0, 1).Value 'nbre de joueurs par équipe iNbEq = Int(iNbJ / iEq) 'nbre d'équipes ' iNbEqP = Range("C2:C5").Find(what:="P", lookat:=xlWhole).Offset(0, 1).Value 'nbre d'équipes par poule iNbEqP1 = Range("C2:C5").Find(what:="P", lookat:=xlWhole).Offset(0, 2).Value 'nbre d'équipes de substitution par poule ' iOK = 0 'indice de correspondance iNbP = Int(iNbEq / iNbEqP) 'nbre de poules complètes For x = iNbP To 0 Step -1 iNbP1 = iNbEq - (iNbEqP * x) 'calcule les possibilités de poules complètes avec, éventuellement, des poules de substitution If iNbP1 Mod iNbEqP1 = 0 Then '...si correspondance est trouvée 'Tirage des poules Columns("J:Z").ClearContents For y = 1 To IIf(iNbP1 / iNbEqP1 &gt; 0, 2, 1) For Z = 1 To IIf(y = 1, x, iNbP1 / iNbEqP1) iNP1 = 0 iNP = iNP + 1 If iNP &gt; 1 Then iLig = iLig + 1 For k = 1 To IIf(y = 1, iNbEqP, iNbEqP1) iLig = iLig + 1 ReDim Preserve tDataGR(iEq + 1, iLig) If iNP1 = 0 Then tDataGR(0, iLig - 1) = "Poule " &amp; iNP iNP1 = 1 Randomize iOK = 0 Do iIdx = 1 + Int(Rnd * iNbEq) iIdx1 = 1 + ((iIdx - 1) * iEq) If tDataJ(iIdx1, 2) = 0 Then For w = 0 To iEq - 1 tDataJ(iIdx1 + w, 2) = 1 tDataGR(w + 1, iLig - 1) = tDataJ(iIdx1 + w, 1) Next iOK = 1 End If Loop Until iOK = 1 Next Next Next Range("J1").Resize(UBound(tDataGR, 2), UBound(tDataGR, 1)).Value = WorksheetFunction.Transpose(tDataGR) Columns("J:Z").AutoFit ' MsgBox iNbJ &amp; " joueurs forment " &amp; iNbEq &amp; " équipes = " &amp; iNbEq * iEq &amp; " joueurs." &amp; Chr(10) &amp; _ IIf(iNbJ Mod iEq &gt; 0, IIf(iNbJ Mod iEq = 1, Chr(10) &amp; "Un joueur reste sans équipe!" &amp; _ Chr(10), Chr(10) &amp; iNbJ Mod iEq &amp; " joueurs restent sans équipe!" &amp; Chr(10)), "") &amp; _ Chr(10) &amp; IIf(x = 0, "Aucune poule de " &amp; iNbEqP &amp; " équipes", IIf(x = 1, "1 poule de " &amp; iNbEqP &amp; " équipes", x &amp; " poules de " &amp; iNbEqP &amp; " équipes")) &amp; _ IIf(iNbP1 / iNbEqP1 &gt; 0, " et " &amp; IIf(iNbP1 / iNbEqP1 &gt; 1, iNbP1 / iNbEqP1 &amp; " poules de ", "1 poule de ") &amp; iNbEqP1 &amp; " équipes.", "."), _ vbInformation, "Tirage des poules" Exit For End If Next ' If iOK = 0 Then MsgBox "La répartition a échoué!" &amp; Chr(10) &amp; "Veuillez choisir une autre configuration!", vbCritical, "Tirage des poules" End If ' Application.EnableEvents = True ' End Sub Avec plaisir! A+ Je viens seulement de capter que le fichier fait 5,5 Mo !!!! Je poste dès que je peux... Voilà, 25Ko, mieux......