Bonjour le forum,
Comment mettre de l'ordre dans les résultats d'un tri éffectué avec un algorythme.
Merci d'avance de votre aide
Cordialement
Margar
Ci-joint petit progr. pour explication approfondie
Version imprimable
Bonjour le forum,
Comment mettre de l'ordre dans les résultats d'un tri éffectué avec un algorythme.
Merci d'avance de votre aide
Cordialement
Margar
Ci-joint petit progr. pour explication approfondie
Bonjour MARGAR,
Cela fait plaisir de voir du code bien indenté et bien commenté.
Je ne me suis pas plongé dedans mais je t'ai fait un bout de code pour déterminer le nombre de doublettes et de triplettes :
BertrandCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20 Sub nbdedoublettetriplette() Dim nbdedoublette, nbdetriplette, nbtotalinscrits As Integer nbtotalinscrits = InputBox("Nombre total d'inscrits ?") Select Case nbtotalinscrits Mod 3 Case 0 nbdetriplette = Int(nbtotalinscrits / 3) nbdedoublette = 0 Case 1 nbdetriplette = Int(nbtotalinscrits / 3) - 1 nbdedoublette = 2 Case 2 nbdetriplette = Int(nbtotalinscrits / 3) nbdedoublette = 1 End Select MsgBox "Pour " & nbtotalinscrits & " inscrits, il y aura " & nbdetriplette & " équipe(s) de triplette et " & nbdedoublette & " équipe(s) de doublette" End Sub
Salut Bertand,
Désolé mais ton code ne fonctionne pas avec le programme :(
Cordialement
Marcel
Bien sûr qu'il faut l'adapter à ton contexte - mais je t'assure que la macro fonctionne à merveille.
Dans ton code tu indiques :
Donc le nombre d'équipe n'est pas calculé par Excel mais tu l'as préalablement saisi en cellule F29...Code:Nb_Equipes = Range("F29")
Il faut procéder par ordre :
1. Saisir les inscriptions avec catégorie
2. En fonction des inscriptions, calculer le nombre d'équipe et pour chaque équipe savoir s'il s'agit d'une doublette ou d'une triplette
3. Effectuer le tirage au sort
4. Déterminer le nombre de tour
5. Ordonner les résultats
J'ai l'impression que tu veux commencer par la fin.
Donc, commences par mettre en forme un tableau d'inscription (avec Nom/Prénom/Catégorie) puis par individu et grâce à mon code, on pourra savoir de quel équipe il fait parti et si cette équipe est une doublette ou une triplette.
Procèdes par étape, c'est plus simple.
Bertrand
Bonjour si ça peut vous aider à avancer, j'avais fait un bout de code pour un tournoi d'Echec.
Dispo en PJ
cordialement
@ Bear the french,
ok, je vais faire de mon mieux.
Merci d'avance
@ evx136,
bien gentil de ta proposition mais cela ne me convient pas.
Merci et bonne journée
Bon, on y va étape par étape.
Déjà une question, sur le tableau ci dessous, je ne trouve pas de résultat pour 7 joueurs :
http://i34.servimg.com/u/f34/17/54/33/62/margar10.jpg
Pour l'amorce, j'ai fait un fichier qui met à jour automatiquement le nombre de joueurs inscrits, le nombre de triplettes, le nombre de doublettes et donc le nombre total d'équipes. A tester avec des noms bidons et me dire si le début convient.
Je ne sais pas s'il faut un tableau par catégorie (un tableau pour les licenciés, pour les femmes, pour les enfants par exemple)... On va dire que les inscrits dans mon tableau sont tous de la même catégorie et sont donc tous susceptibles de se rencontrer.
Le début du code :
BertrandCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28 Option Explicit Dim nbdedoublette, nbdetriplette, nbtotalinscrits As Integer Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'déclenchement de la macro si changement sur les cellules concernées If Not Intersect(Target, Range("B4:C65000")) Is Nothing Then ' met à jours le nombre de noms inscrits Range("I1").Value = [B65536].End(xlUp).Row - 5 End If ' initialisation des variables nbtotalinscrits = Range("I1").Value nbdetriplette = 0 nbdedoublette = 0 ' algorythme qui détermine le nombre de doublette et triplette If nbtotalinscrits > 3 Then nbdetriplette = Sheets("Equipe").Range("B" & nbtotalinscrits - 2).Value nbdedoublette = Sheets("Equipe").Range("C" & nbtotalinscrits - 2).Value End If ' transcriptions des résultats sur la feuille Range("F1").Value = nbdetriplette + nbdedoublette Range("F2").Value = nbdetriplette Range("F3").Value = nbdedoublette End Sub
Version 1-1 = chaque joueur se voit affecter dans une doublette ou une triplette - et l'équipe à un numéro qui lui est affecté.
BertrandCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56 Option Explicit Dim nbdedoublette, nbdetriplette, nbtotalinscrits As Integer Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim i, x, y, numequipe As Integer 'déclenchement de la macro si changement sur les cellules concernées If Not Intersect(Target, Range("B4:C65000")) Is Nothing Then ' met à jours le nombre de noms inscrits Range("I1").Value = [B65536].End(xlUp).Row - 5 End If ' initialisation des variables nbtotalinscrits = Range("I1").Value nbdetriplette = 0 nbdedoublette = 0 ' algorythme qui détermine le nombre de doublette et triplette If nbtotalinscrits > 3 Then nbdetriplette = Sheets("Equipe").Range("B" & nbtotalinscrits - 2).Value nbdedoublette = Sheets("Equipe").Range("C" & nbtotalinscrits - 2).Value End If ' transcriptions des résultats sur la feuille Range("F1").Value = nbdetriplette + nbdedoublette Range("F2").Value = nbdetriplette Range("F3").Value = nbdedoublette ' initialisation des variables Range("E6:F59").ClearContents x = nbdetriplette * 3 y = nbdedoublette * 2 numequipe = 0 ' affecte le numéro d'équipe et le type d'équipe For i = 6 To 6 + nbtotalinscrits If x <> 0 Then If x Mod 3 = 0 Then numequipe = numequipe + 1 End If Range("E" & i).Value = numequipe Range("F" & i).Value = "Triplette" x = x - 1 Else If y <> 0 Then If y Mod 2 = 0 Then numequipe = numequipe + 1 End If Range("E" & i).Value = numequipe Range("F" & i).Value = "Doublette" y = y - 1 End If End If Next i End Sub
En ce qui concerne ta question sur le tableau :
Cela ne fonctionne pas avec 7 joueurs car cela n'est pas possible de créer d'équipes de Triplettes et/ou de Doublettes. C'est le seul cas qui n'est pas possible.
Pour ce qui est des Noms et Prénoms chez nous, on les répertorie comme ceci, par ex. on attribue un N° à chaques Prénoms et on ne prend pas en compte les Noms. On les encode via une liste déroulante.
Ex : 001 LEON
002 JEANINE
003 MARC
004 MICHEL
005 RITA
Ok, je tiens compte de ta remarque.
Version 1-2 : correctif --> 7 joueurs pas de solution, apparition d'un tableau avec les équipes constituées sous la forme "Equipe n°X : 001 LEON + 002 PIERRE + 003 PATRICE"
Etape suivante : tirage au sort des rencontres.
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78 Option Explicit Dim nbdedoublette, nbdetriplette, nbtotalinscrits As Integer Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim i, x, y, numequipe As Integer Dim texteequipe As String If Target.Count > 1 Then Exit Sub 'déclenchement de la macro si changement sur les cellules concernées If Not Intersect(Target, Sheets("Inscription").Range("B4:C59")) Is Nothing Then ' met à jours le nombre de noms inscrits Application.EnableEvents = False Sheets("Inscription").Range("I1").Value = [B60].End(xlUp).Row - 5 ' initialisation des variables nbtotalinscrits = Sheets("Inscription").Range("I1").Value nbdetriplette = 0 nbdedoublette = 0 ' algorythme qui détermine le nombre de doublette et triplette If nbtotalinscrits > 3 Then nbdetriplette = Sheets("Equipe").Range("B" & nbtotalinscrits + 1).Value nbdedoublette = Sheets("Equipe").Range("C" & nbtotalinscrits + 1).Value End If ' transcriptions des résultats sur la feuille Sheets("Inscription").Range("F1").Value = nbdetriplette + nbdedoublette Sheets("Inscription").Range("F2").Value = nbdetriplette Sheets("Inscription").Range("F3").Value = nbdedoublette ' initialisation des variables Sheets("Inscription").Range("E6:F59").ClearContents x = nbdetriplette * 3 y = nbdedoublette * 2 numequipe = 0 ' affecte le numéro d'équipe et le type d'équipe For i = 6 To 6 + nbtotalinscrits If x <> 0 Then If x Mod 3 = 0 Then numequipe = numequipe + 1 End If Sheets("Inscription").Range("E" & i).Value = numequipe Sheets("Inscription").Range("F" & i).Value = "Triplette" x = x - 1 Else If y <> 0 Then If y Mod 2 = 0 Then numequipe = numequipe + 1 End If Sheets("Inscription").Range("E" & i).Value = numequipe Sheets("Inscription").Range("F" & i).Value = "Doublette" y = y - 1 End If End If Next i ' initialisation des variables Sheets("Inscription").Range("H6:J23").ClearContents x = nbdetriplette * 3 y = nbdedoublette * 2 numequipe = 0 ' rempli la liste d'équipe et le type d'équipe For i = 6 To [E60].End(xlUp).Row If Sheets("Inscription").Range("E" & i).Value <> Sheets("Inscription").Range("E" & i - 1).Value Then texteequipe = Sheets("Inscription").Range("A" & i).Value & " " & Sheets("Inscription").Range("C" & i).Value Sheets("Inscription").Range("H" & Sheets("Inscription").Range("E" & i).Value + 5).Value = "Equipe n°" & Sheets("Inscription").Range("E" & i).Value & " : " & texteequipe Else texteequipe = texteequipe & " + " & Sheets("Inscription").Range("A" & i).Value & " " & Sheets("Inscription").Range("C" & i).Value Sheets("Inscription").Range("H" & Sheets("Inscription").Range("E" & i).Value + 5).Value = "Equipe n°" & Sheets("Inscription").Range("E" & i).Value & " : " & texteequipe End If Next i Application.EnableEvents = True End If End Sub
Bertrand
Ok pour la suppression des N° d'équipes.
Je te joins un petit fichier pour y voir un peu plus !
Je viens de faire un essai pour te l'envoyer, mais, même Zippé (586 Ko), il ne le prend pas !!!
Je peux peut-être te l'envoyer via un e-mail ?
Marcel
Deux solutions :
1. Utiliser dl.free.fr (je ne sais pas si les administrateurs l'autorisent - donc adresses moi le lien généré par MP)
2. Atteindre 10 pouces levés je crois pour te permettre de joindre un fichier... Mais la première solution parait plus rapide :?
Bertrand
Nouvelle version - v1-3 : sans les numéros d'équipe qui sont masqués et nouvelle présentation
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77 Option Explicit Dim nbdedoublette, nbdetriplette, nbtotalinscrits As Integer Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim i, x, y, numequipe As Integer Dim texteequipe As String If Target.Count > 1 Then Exit Sub 'déclenchement de la macro si changement sur les cellules concernées If Not Intersect(Target, Sheets("Inscription").Range("B4:C59")) Is Nothing Then Application.EnableEvents = False ' initialisation des variables nbtotalinscrits = [B60].End(xlUp).Row - 5 ' met à jours le nombre de noms inscrits nbdetriplette = 0 nbdedoublette = 0 ' algorythme qui détermine le nombre de doublette et triplette If nbtotalinscrits > 3 Then nbdetriplette = Sheets("Equipe").Range("B" & nbtotalinscrits + 1).Value nbdedoublette = Sheets("Equipe").Range("C" & nbtotalinscrits + 1).Value End If ' transcriptions des résultats sur la feuille Sheets("Inscription").Range("F1").Value = nbdetriplette + nbdedoublette Sheets("Inscription").Range("F2").Value = nbdetriplette Sheets("Inscription").Range("F3").Value = nbdedoublette Sheets("Inscription").Range("J6").Value = nbtotalinscrits ' initialisation des variables Sheets("Inscription").Range("E6:F59").ClearContents x = nbdetriplette * 3 y = nbdedoublette * 2 numequipe = 0 ' affecte le numéro d'équipe et le type d'équipe For i = 6 To 6 + nbtotalinscrits If x <> 0 Then If x Mod 3 = 0 Then numequipe = numequipe + 1 End If Sheets("Inscription").Range("E" & i).Value = numequipe Sheets("Inscription").Range("F" & i).Value = "Triplette" x = x - 1 Else If y <> 0 Then If y Mod 2 = 0 Then numequipe = numequipe + 1 End If Sheets("Inscription").Range("E" & i).Value = numequipe Sheets("Inscription").Range("F" & i).Value = "Doublette" y = y - 1 End If End If Next i ' initialisation des variables Sheets("Inscription").Range("H15:J32").ClearContents x = nbdetriplette * 3 y = nbdedoublette * 2 numequipe = 0 ' rempli la liste d'équipe et le type d'équipe For i = 6 To [E60].End(xlUp).Row If Sheets("Inscription").Range("E" & i).Value <> Sheets("Inscription").Range("E" & i - 1).Value Then Sheets("Inscription").Range("H" & Sheets("Inscription").Range("E" & i).Value + 14).Value = CStr("Equipe = " & Sheets("Inscription").Range("A" & i).Value & " " & Sheets("Inscription").Range("C" & i).Value) Else Sheets("Inscription").Range("H" & Sheets("Inscription").Range("E" & i).Value + 14).Value = Sheets("Inscription").Range("H" & Sheets("Inscription").Range("E" & i).Value + 14).Value & " + " & Sheets("Inscription").Range("A" & i).Value & " " & Sheets("Inscription").Range("C" & i).Value End If Next i Application.EnableEvents = True End If End Sub
Bertrand,
voici le lien concernant mon fichier : http://dl.free.fr/rWF57i7vx
Marcel
Bon il nous faut analyser ton algorithme de tirage aléatoire (au passage j'ai fait un peu de ménage) :
Je n'ai pas 36 solutions pour comprendre. On va reprendre étape par étape :Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130 Sub TirageV2() Dim Tablo, temp Dim I As Integer, J As Long, k As Integer, L As Byte Dim NbJ As Integer Dim Nb3 As Long Dim Nb2 As Long Dim Num As Long Dim Cl As Integer Dim NbManche As Byte Dim Alea As Integer Dim Cel As Range Dim Plage As Range With Sheets("Liste") Tablo = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row) End With NbJ = UBound(Tablo) With Sheets("Recap") .Range("B3:B100").ClearContents For I = 1 To NbJ .Cells(I + 2, 2) = Tablo(I, 1) Next I End With Select Case NbJ Mod 3 ' Reste entier sur la division NbJ/3 Case 0 If (NbJ / 3) Mod 2 > 0 Then ' Nombre équipe impair Nb3 = (NbJ / 3) - 2 Nb2 = 3 Else Nb3 = NbJ / 3 Nb2 = 0 End If Case 1 If ((NbJ \ 3) - 1) Mod 2 = 0 Then ' 1 équipe de 3 en moins = nombre pair Nb3 = (NbJ \ 3) - 1 Nb2 = 2 Else Nb3 = (NbJ \ 3) - 3 Nb2 = 5 End If Case 2 If (NbJ \ 3) Mod 2 = 0 Then ' Nombre équipe de 3 pair Nb3 = (NbJ \ 3) - 2 Nb2 = 4 Else Nb3 = (NbJ \ 3) Nb2 = 1 End If End Select ' On efface tous les tableaux For L = 1 To 5 Sheets("P" & L).Range("A4:H12,I4:I12").ClearContents Next L Randomize ReDim Preserve Tablo(1 To UBound(Tablo, 1), 1 To UBound(Tablo, 2) + 1) If UserForm1.OptionButtonManche3 = True Then NbManche = 3 End If If UserForm1.OptionButtonManche4 = True Then NbManche = 4 End If If UserForm1.OptionButtonManche5 = True Then NbManche = 5 End If For L = 1 To NbManche ' Numérotation aléatoire des joueurs For I = 1 To UBound(Tablo, 1) Tablo(I, UBound(Tablo, 2)) = Rnd Next I ' Tri en fonction du numérotage For I = 1 To UBound(Tablo, 1) For J = 1 To UBound(Tablo, 1) If Tablo(I, UBound(Tablo, 2)) > Tablo(J, UBound(Tablo, 2)) Then For k = 1 To UBound(Tablo, 2) temp = Tablo(I, k) Tablo(I, k) = Tablo(J, k) Tablo(J, k) = temp Next k End If Next J Next I With Sheets("P" & L) J = 4 ' 1ère ligne Cl = 1 Num = 0 For I = 1 To Nb3 ' Pour toutes les triplettes For k = 0 To 2 ' Pour 3 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 If Cl = 7 Then Cl = 1 J = J + 1 End If Next k Next I For I = 1 To Nb2 ' Pour toutes les doublettes For k = 0 To 1 ' Pour 2 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 If Cl = 3 Then Cl = 4 ElseIf Cl = 6 Then Cl = 1 J = J + 1 End If Next k Next I Set Plage = .Range("I4:I" & J - 1) For Each Cel In Plage Autre: Alea = Int(9 * Rnd + 1) If Application.CountIf(Plage, Alea) Then GoTo Autre Else Cel = Alea Next Cel End With Next L Application.ScreenUpdating = True End Sub
Code:
1
2
3
4 With Sheets("Liste") Tablo = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row) End With NbJ = UBound(Tablo)
Là il semble que tu charges dans un tableau de variables chacun des inscrits sous la forme "00X Prénom" puis tu détermines le nombre de joueurs au total (NbJ).
Pas de souci.
Code:
1
2
3
4
5
6 With Sheets("Recap") .Range("B3:B100").ClearContents For I = 1 To NbJ .Cells(I + 2, 2) = Tablo(I, 1) Next I End With
Là tu copies les inscrits dans une feuille masquée, appelée "Recap". Là par contre, il y a un truc étrange : pourquoi ton tableau Tablo a deux dimensions ? Pourquoi Tablo(I, 1) plutôt que Tablo(I) ?
Deuxième truc étrange : les variables tableau ne commencent pas à Tablo(1) mais à Tablo(0). Donc je ne comprend pas. J'aurai remplacé Tablo(I, 1) par Tablo(I-1).
Au passage la déclaration de ton tableau Tablo est à reprendre
Code:Dim Tablo() As String
Bertrand
Franchement, je ne sais plus car ce fichier date depuis plusieurs années.
S'il te semble qu'il y a des corrections à y faire, fais pour un mieux.
Marcel
Après avoir vérifier dans mes tablettes, ton code est juste pour la partie tableau --> en affectant une plage, la deuxième dimension du tableau est créée automatiquement et elle correspond au numéro de la colonne. Le premier indice de ce tableau est 1 et non zéro. Va falloir que je révise un peu :oops:
Mes excuses pour cette erreur.
Par contre, je déclarerai bien
Code:Dim Tablo() As Variant
Bertrand
Cool Bertrand, la zenattitude doit toujours primer...
Marcel
Analysons la suite :
On cherche à calculer le Modulo du Nombre de joueurs divisé par 3.Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26 Select Case NbJ Mod 3 ' Reste entier sur la division NbJ/3 Case 0 If (NbJ / 3) Mod 2 > 0 Then ' Nombre équipe impair Nb3 = (NbJ / 3) - 2 Nb2 = 3 Else Nb3 = NbJ / 3 Nb2 = 0 End If Case 1 If ((NbJ \ 3) - 1) Mod 2 = 0 Then ' 1 équipe de 3 en moins = nombre pair Nb3 = (NbJ \ 3) - 1 Nb2 = 2 Else Nb3 = (NbJ \ 3) - 3 Nb2 = 5 End If Case 2 If (NbJ \ 3) Mod 2 = 0 Then ' Nombre équipe de 3 pair Nb3 = (NbJ \ 3) - 2 Nb2 = 4 Else Nb3 = (NbJ \ 3) Nb2 = 1 End If End Select
Trois cas de figures :
- Modulo = 0
- Modulo = 1
- Modulo = 2
En bref, cette partie calcule le nombre de doublettes et le nombre de triplettes (ça, on savait déjà le faire).
C'est intéressant de noter que :
Nb3 = le nombre de triplettes
Nb2 = le nombre de doublettes
Bertrand
Ok pour effacer les anciens tableaux. L'information que je retiens : à priori un tournoi se joue en 5 manches ?Code:
1
2
3
4 ' On efface tous les tableaux For L = 1 To 5 Sheets("P" & L).Range("A4:H12,I4:I12").ClearContents Next L
Bertrand
En fait, c'est un programme qui tourne très bien mais le problème se pose au tirage aléatoire en créant des doublons, ce qui rend certains joueurs râleurs...
Marcel
Au départ, lorsque l'on inscrit les joueurs, avant de faire le tirage, on a le choix entre 3, 4 ou 5 manches.
En général, on joue 4 manches, rarement 5 et encore plus rarement 3.
Marcel
Qu'est ce que tu appelles un doublon ?
Un même joueur dans deux équipes differentes ?
Bertrand
un doublon, c'est 2 joueurs qui jouent 2 ou 3 fois ensemble, par ex :
Manche 1 : LEON / RITA / CLAUDY contre ALAIN / RENE / BOB
Manche 3 : on retrouve :
LEON / RITA / BERTRAND contre MARCEL / NADINE / JOEL.
Marcel
Une nouveauté pour moi --> A chaque manche il y a un tirage pour la composition des équipes ?
D'ailleurs, je pensais les seules rencontres aléatoires mais pas la composition des équipes (je pensais que la composition était en fonction de l'ordre d'inscription).
Bertrand
Tout à fait, tout est aléatoire et c'est probablement à cause de cela que l'on retrouve des doublons, alors qu'avec la macro de l'algoritme, il n'y en a plus !
Marcel
Ok.
Continuons l'exploration de la macro de tirage au sort.
Code:Randomize
C'est du classique : Initialisation du générateur de nombres aléatoires
Code:ReDim Preserve Tablo(1 To UBound(Tablo, 1), 1 To UBound(Tablo, 2) + 1)
On redimensionne le tableau Tablo en rajoutant un élément sur la deuxième dimension. Difficile de dire à quoi ça va servir à ce stade
Code:
1
2
3
4
5
6
7
8
9 If UserForm1.OptionButtonManche3 = True Then NbManche = 3 End If If UserForm1.OptionButtonManche4 = True Then NbManche = 4 End If If UserForm1.OptionButtonManche5 = True Then NbManche = 5 End If
En fonction de l'option cochée sur le formulaire, on détermine le nombre de manches (soit 3, soit 4, soit 5)
Prochaine étape : enfin le coeur du système...
Bertrand
Enfin le coeur du système.... yessss, on y arrive... petit à petit l'oiseau fait son nid...
Marcel
Code:For L = 1 To NbManche
On crée une boucle que l'on va répéter en fonction du nombre de manches
Code:
1
2
3
4 ' Numérotation aléatoire des joueurs For I = 1 To UBound(Tablo, 1) Tablo(I, UBound(Tablo, 2)) = Rnd Next I
On crée une boucle que l'on va répéter en fonction du nombre d'inscrits. Pour chaque inscrit, on affecte un Rnd (un nombre aléatoire) dans la dimension nouvellement créée.
Là encore, c'est du classique.
Code:
1
2
3
4
5
6
7
8
9
10
11
12 ' Tri en fonction du numérotage For I = 1 To UBound(Tablo, 1) For J = 1 To UBound(Tablo, 1) If Tablo(I, UBound(Tablo, 2)) > Tablo(J, UBound(Tablo, 2)) Then For k = 1 To UBound(Tablo, 2) temp = Tablo(I, k) Tablo(I, k) = Tablo(J, k) Tablo(J, k) = temp Next k End If Next J Next I
On crée un algorithme de tri à bulle pour ordonner les éléments obtenus par le mode aléatoire. Toujours du classique.
Par contre, il est important de noter qu'à chaque nouvelle manche, l'ordre se perd, écrasé par la boucle de la manche suivante
Bertrand
Beaucoup trop classique, peut-être...
C'est pour cela qu'il est temps d'essayer de remplacer cet algorithme par le nouveau.
Marcel
Code:With Sheets("P" & L)
On sélectionne l'onglet de la manche sur laquelle on boucle.
Code:
1
2
3 J = 4 ' 1ère ligne Cl = 1 Num = 0
Sans doute la phase d'initialisation des variables :
J = la première ligne à remplir
Cl = je suppose la colonne à remplir
num = la variable qui va s'incrémenter et représenter l'indice du tableau.
Code:
1
2
3
4
5
6
7
8
9
10
11 For I = 1 To Nb3 ' Pour toutes les triplettes For k = 0 To 2 ' Pour 3 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 If Cl = 7 Then Cl = 1 J = J + 1 End If Next k Next I
La boucle qui affecte les triplettes = chaque participant est placé progressivement selon l'ordre obtenu sur la base des nombres aléatoires reclassés par le tri à bulle.
Cl est bien le n° de la colonne --> lorsqu'il atteint 7, on passe à la ligne (J=J+1) et la colonne repasse à 1 (Cl = 1).
A chaque participant placé, num s'incrémente de 1.
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13 For I = 1 To Nb2 ' Pour toutes les doublettes For k = 0 To 1 ' Pour 2 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 If Cl = 3 Then Cl = 4 ElseIf Cl = 6 Then Cl = 1 J = J + 1 End If Next k Next I
La boucle qui affecte les doublettes = chaque participant est placé progressivement selon l'ordre obtenu sur la base des nombres aléatoires reclassés par le tri à bulle.
Cl est bien le n° de la colonne -->
lorsqu'il atteint 3, la colonne passe directement à 4,
lorsqu'il atteint 6, la colonne repasse à 1 (Cl = 1) et la ligne change.
A chaque participant placé, num s'incrémente de 1.
Bertrand
Ton analyse est parfaite.
Marcel
Code:
1
2
3
4
5
6
7 Set Plage = .Range("I4:I" & J - 1) For Each Cel In Plage Autre: Alea = Int(9 * Rnd + 1) If Application.CountIf(Plage, Alea) Then GoTo Autre Else Cel = Alea Next Cel End With
Dernière partie : manifestement, on affecte un des neuf terrains à chaque rencontre. Il y a un GoTo... hum, on verra
Code:Set Plage = .Range("I4:I" & J - 1)
La plage où sont renseignés les terrains
Code:For Each Cel In Plage
Pour chacune des rencontres
Code:
1
2
3
4 Autre: Alea = Int(9 * Rnd + 1) If Application.CountIf(Plage, Alea) Then GoTo Autre Else Cel = Alea Next Cel
Rnd donne un nombre aléatoire entre 0 et 1. Une fois multiplié par 9 et ajouté à 1, on retient la partie entière. Application.CountIf(Plage, Alea) permet de vérifier que le numéro du terrain n'ai pas déjà tiré au sort. Si c'est le cas, le Goto provoque un renvoi à la ligne "Autre:"
L'analyse se termine là.
Les conclusions : il n'y a aucun rapprochement entre les tirages de chaque manche donc il peut y avoir des doublons. A part ça, c'est du classique et c'est plutôt bien.
Il faut donc mémoriser le tirage de chaque manche et être capable de rapprocher les résultats.
Qu'est ce qui pose problème :
D'être deux fois (ou plus) associé aux mêmes partenaires ?
D'être deux fois (ou plus) confronté aux mêmes adversaires ?
Ou les deux ?
Bertrand
Le top serait les 3 mais la plus importante est d'abord :
la 1ère de ne pas jouer 2 fois avec le même partenaire, ensuite
la 2ème serait idéale, de ne pas rencontrer 2 fois le même partenaire et
la 3éme, le summum...
Marcel
Il va falloir se creuser les méninges.
On va déjà essayer "de ne pas jouer 2 fois avec le même partenaire"
A priori, le numéro d'équipe, même s'il n'est pas apparent permettrait de comparer entre les manches. Peut-être à travers un deuxième tableau de variables qui partagerai les mêmes indices.
Le deuxième problème, c'est qu'en plus de déceler l'anomalie, il faut être en mesure de la corriger. C'est à dire de relancer un tirage complet, jusqu'à satisfaction...
Bertrand
Petite question Bertrand :
Ne peut-on pas remplacer cette macro-ci, par la macro de l'algorithme que j'ai mis sur le forum et essayer de l'adapter au reste du programme et en l'exploitant au maximum?
Marcel
Je ne comprend pas : tu veux modifier le fichier que nous avons analysé ? Modifier mon amorce précédente ? Ou autre chose ?
Si tu as déjà une idée de modification, je suis preneur ;)
De mon coté, j'avais dans l'idée de faire un fichier épuré sur la base de la macro analysée.
Bertrand
Ok, pour moi, pas de problème pour une solution ou l'autre, à partir du moment
que le résultat final, soit le meilleur...
Bertrand, ne penses-tu pas qu'il est temps d'aller faire un petit somme et que de toute façon, ne dit-on, que la nuit porte conseil.
En plus, Morphée sera ravie de notre présence... :zoubi:
A demain Bertand et bonne nuit
Marcel
Bonjour,
Bon, j'ai une solution mais elle n'est pas top pour l'instant (il y a du goto, c'est lent, ...)
Les plus : On remplit la liste sur la gauche dans l'onglet "Liste", on choisit le nombre de manches puis on lance le tirage.
J'ai mis un critère : la recherche de combinaison n'est lancée qu'à partir de 17 participants ou plus. Sinon, ça peut durer un bon moment (et ça c'est le moins).
La méthode : relancer un tirage sur la dernière manche, vérifier si c'est bon, si ce n'est pas le cas, relancer un tirage... Jusqu'à 5.000 tentatives.
Une fois la cinq mille une ième tentative atteinte et ce sans avoir trouvé la combinaison, on relance un tirage depuis la première manche.
Ce qui est le plus long, c'est avec 5 manches et moins d'individus.
En bref, c'est visuellement sympa de voir calculer l'ordi mais ce n'est pas efficace. A voir ce que d'autres forumeurs peuvent produire.
Consignes de sécurité : si la boucle dure trop longtemps ou si on lance une boucle sans résultat possible --> combinaison des touches Ctrl + Pause pour en sortir.
BertrandCode:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159 Option Explicit Sub TirageV2() Dim Tablo Dim temp As String Dim I As Integer, X As Integer, J As Long, k As Integer Dim NbJ As Integer, L As Integer, NbManche As Integer, nbparticipant As Integer Dim Nb3 As Long, Nb2 As Long, Num As Long Dim Cl As Integer, equipe As Integer Dim Alea As Integer, compteur As Integer Dim Cel As Range, Plage As Range Tablo = Sheets("Liste").Range("A2:A" & Sheets("Liste").Range("A" & Rows.Count).End(xlUp).Row) NbJ = UBound(Tablo) Select Case NbJ Mod 3 ' Reste entier sur la division NbJ/3 Case 0 If (NbJ / 3) Mod 2 > 0 Then ' Nombre équipe impair Nb3 = (NbJ / 3) - 2 Nb2 = 3 Else Nb3 = NbJ / 3 Nb2 = 0 End If Case 1 If ((NbJ \ 3) - 1) Mod 2 = 0 Then ' 1 équipe de 3 en moins = nombre pair Nb3 = (NbJ \ 3) - 1 Nb2 = 2 Else Nb3 = (NbJ \ 3) - 3 Nb2 = 5 End If Case 2 If (NbJ \ 3) Mod 2 = 0 Then ' Nombre équipe de 3 pair Nb3 = (NbJ \ 3) - 2 Nb2 = 4 Else Nb3 = (NbJ \ 3) Nb2 = 1 End If End Select NbManche = Sheets("Liste").Range("AK1").Value ' On efface tous les tableaux For L = 1 To 5 Sheets("P" & L).Range("A4:H12,I4:I12").ClearContents Next L Sheets("Liste").Range("C2:Q55").ClearContents nbparticipant = UBound(Tablo, 1) Randomize ReDim Preserve Tablo(1 To nbparticipant, 1 To 3) Autre3: compteur = 1 For L = 1 To NbManche Autre2: Application.EnableEvents = False ' Numérotation aléatoire des joueurs For I = 1 To nbparticipant Tablo(I, 2) = Rnd Next I ' Tri en fonction du numérotage For I = 1 To UBound(Tablo, 1) For J = 1 To UBound(Tablo, 1) If Tablo(I, 2) > Tablo(J, 2) Then For k = 1 To UBound(Tablo, 2) temp = Tablo(I, k) Tablo(I, k) = Tablo(J, k) Tablo(J, k) = temp Next k End If Next J Next I With Sheets("P" & L) J = 4 ' 1ère ligne Cl = 1 Num = 0 equipe = 1 For I = 1 To Nb3 ' Pour toutes les triplettes For k = 0 To 2 ' Pour 3 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 Tablo(Num, 3) = equipe If Num Mod 3 = 0 Then equipe = equipe + 1 End If If Cl = 7 Then Cl = 1 J = J + 1 End If Next k Next I For I = 1 To Nb2 ' Pour toutes les doublettes For k = 0 To 1 ' Pour 2 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 Tablo(Num, 3) = equipe If (Num - (Nb3 * 3)) Mod 2 = 0 Then equipe = equipe + 1 End If If Cl = 3 Then Cl = 4 ElseIf Cl = 6 Then Cl = 1 J = J + 1 End If Next k Next I If nbparticipant > 16 Then 'évite les doublons pour plus de 16 participants For I = 1 To nbparticipant For X = 1 To nbparticipant If Tablo(I, 3) = Tablo(X, 3) And I <> X Then If Sheets("Liste").Cells(Application.Match(Tablo(I, 1), Sheets("Liste").Range("A1:A55"), 0), 1 + 3 * L).Value = "" Then k = Application.Match(Tablo(I, 1), Sheets("Liste").Range("A1:A55"), 0) Sheets("Liste").Cells(k, 1 + 3 * L).Value = Tablo(X, 1) Else Sheets("Liste").Cells(k, 2 + 3 * L).Value = Tablo(X, 1) End If End If Next X Next I For I = 1 To nbparticipant If Sheets("Liste").Cells(I + 1, 18).Value > 0 Then If compteur < 5000 Then compteur = compteur + 1 Sheets("Liste").Range(Cells(2, 1 + 3 * L), Cells(55, 2 + 3 * L)).ClearContents GoTo Autre2 Else Sheets("Liste").Range("C2:Q55").ClearContents GoTo Autre3 End If End If Next I End If Application.EnableEvents = True Set Plage = .Range("I4:I" & J - 1) For Each Cel In Plage Autre: Alea = Int(9 * Rnd + 1) If Application.CountIf(Plage, Alea) Then GoTo Autre Else Cel = Alea Next Cel End With Next L Application.ScreenUpdating = True End Sub
Bonjour Bertrand,
D'abord je voudrais te remercier de ton aide éfficace et précieuse.
Je viens d'éffectuer plusieurs tests qui sont à première vue excellents au niveau des doublons entre partenaires jouant ensemble ( il n' y en a plus ).
Serait-il possible maintenant de trouver la solution pour que 2 partenaires ne se rencontrent plus ?
Marcel
Bonjour,
Version 2-1 = évite les doublons "partenaires" et "adversaires"
Le code (à retravailler) :
Je te laisse faire des tests.Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203 Option Explicit Sub TirageV2() Dim Tablo Dim temp As String Dim I As Integer, X As Integer, J As Long, k As Integer Dim NbJ As Integer, L As Integer, NbManche As Integer, nbparticipant As Integer Dim Nb3 As Long, Nb2 As Long, Num As Long Dim Cl As Integer, equipe As Integer, rencontre As Integer Dim Alea As Integer, compteur As Integer Dim Cel As Range, Plage As Range Tablo = Sheets("Liste").Range("A2:A" & Sheets("Liste").Range("A" & Rows.Count).End(xlUp).Row) NbJ = UBound(Tablo) Select Case NbJ Mod 3 ' Reste entier sur la division NbJ/3 Case 0 If (NbJ / 3) Mod 2 > 0 Then ' Nombre équipe impair Nb3 = (NbJ / 3) - 2 Nb2 = 3 Else Nb3 = NbJ / 3 Nb2 = 0 End If Case 1 If ((NbJ \ 3) - 1) Mod 2 = 0 Then ' 1 équipe de 3 en moins = nombre pair Nb3 = (NbJ \ 3) - 1 Nb2 = 2 Else Nb3 = (NbJ \ 3) - 3 Nb2 = 5 End If Case 2 If (NbJ \ 3) Mod 2 = 0 Then ' Nombre équipe de 3 pair Nb3 = (NbJ \ 3) - 2 Nb2 = 4 Else Nb3 = (NbJ \ 3) Nb2 = 1 End If End Select NbManche = Sheets("Liste").Range("AK1").Value ' On efface tous les tableaux For L = 1 To 5 Sheets("P" & L).Range("A4:H12,I4:I12").ClearContents Next L Sheets("Liste").Range("C2:Q55").ClearContents Sheets("Liste").Range("AP2:BD55").ClearContents nbparticipant = UBound(Tablo, 1) Randomize ReDim Preserve Tablo(1 To nbparticipant, 1 To 4) Autre3: compteur = 1 For L = 1 To NbManche Autre2: Application.EnableEvents = False ' Numérotation aléatoire des joueurs For I = 1 To nbparticipant Tablo(I, 2) = Rnd Next I ' Tri en fonction du numérotage For I = 1 To UBound(Tablo, 1) For J = 1 To UBound(Tablo, 1) If Tablo(I, 2) > Tablo(J, 2) Then For k = 1 To UBound(Tablo, 2) temp = Tablo(I, k) Tablo(I, k) = Tablo(J, k) Tablo(J, k) = temp Next k End If Next J Next I With Sheets("P" & L) J = 4 ' 1ère ligne Cl = 1 Num = 0 equipe = 1 rencontre = 1 For I = 1 To Nb3 ' Pour toutes les triplettes For k = 0 To 2 ' Pour 3 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 Tablo(Num, 3) = equipe Tablo(Num, 4) = rencontre If Num Mod 3 = 0 Then equipe = equipe + 1 If equipe Mod 2 = 1 Then rencontre = rencontre + 1 End If End If If Cl = 7 Then Cl = 1 J = J + 1 End If Next k Next I For I = 1 To Nb2 ' Pour toutes les doublettes For k = 0 To 1 ' Pour 2 joueurs Num = Num + 1 ' Indice dans le tableau : Tablo .Cells(J, Cl) = Tablo(Num, 1) Cl = Cl + 1 Tablo(Num, 3) = equipe Tablo(Num, 4) = rencontre If (Num - (Nb3 * 3)) Mod 2 = 0 Then equipe = equipe + 1 If equipe Mod 2 = 1 Then rencontre = rencontre + 1 End If End If If Cl = 3 Then Cl = 4 ElseIf Cl = 6 Then Cl = 1 J = J + 1 End If Next k Next I If nbparticipant > Sheets("Liste").Range("AK2").Value Then 'rempli le tableau "associés" pour plus de For I = 1 To nbparticipant For X = 1 To nbparticipant If Tablo(I, 3) = Tablo(X, 3) And I <> X Then If Sheets("Liste").Cells(Application.Match(Tablo(I, 1), Sheets("Liste").Range("A1:A55"), 0), 1 + 3 * L).Value = "" Then k = Application.Match(Tablo(I, 1), Sheets("Liste").Range("A1:A55"), 0) Sheets("Liste").Cells(k, 1 + 3 * L).Value = Tablo(X, 1) Else Sheets("Liste").Cells(k, 2 + 3 * L).Value = Tablo(X, 1) End If End If Next X Next I 'rempli le tableau "adversaires" pour plus de x participants - x étant renseigné dans la cellule [AK2] de la feuille fiche For I = 1 To nbparticipant For X = 1 To nbparticipant If Tablo(I, 3) <> Tablo(X, 3) And Tablo(I, 4) = Tablo(X, 4) And Tablo(I, 4) <> "" And Tablo(X, 4) <> "" And I <> X Then k = Application.Match(Tablo(I, 1), Sheets("Liste").Range("A1:A55"), 0) If Sheets("Liste").Cells(k, 39 + 3 * L).Value = "" Then Sheets("Liste").Cells(k, 39 + 3 * L).Value = Tablo(X, 1) Else If Sheets("Liste").Cells(k, 40 + 3 * L).Value = "" Then Sheets("Liste").Cells(k, 40 + 3 * L).Value = Tablo(X, 1) Else Sheets("Liste").Cells(k, 41 + 3 * L).Value = Tablo(X, 1) End If End If End If Next X Next I ' test pour vérifier si doublon For I = 1 To nbparticipant If Sheets("Liste").Cells(I + 1, 18).Value > 0 Or Sheets("Liste").Cells(I + 1, 57).Value > 0 Then If compteur < 5000 Then compteur = compteur + 1 Select Case L Case 1: Sheets("Liste").Range("D2:E55").ClearContents: Sheets("Liste").Range("AP2:AR55").ClearContents Case 2: Sheets("Liste").Range("G2:H55").ClearContents: Sheets("Liste").Range("AS2:AU55").ClearContents Case 3: Sheets("Liste").Range("J2:K55").ClearContents: Sheets("Liste").Range("AV2:AX55").ClearContents Case 4: Sheets("Liste").Range("M2:N55").ClearContents: Sheets("Liste").Range("AY2:BA55").ClearContents Case 5: Sheets("Liste").Range("P2:Q55").ClearContents: Sheets("Liste").Range("BB2:BD55").ClearContents End Select GoTo Autre2 Else Sheets("Liste").Range("D2:Q55").ClearContents Sheets("Liste").Range("AP2:BD55").ClearContents GoTo Autre3 End If End If Next I End If End With Application.EnableEvents = True Set Plage = Sheets("P" & L).Range("I4:I" & J - 1) For Each Cel In Plage Autre: Alea = Int(9 * Rnd + 1) If Application.CountIf(Plage, Alea) Then GoTo Autre Else Cel = Alea End If Next Cel Next L Application.ScreenUpdating = True End Sub
Bertrand
Bertrand,
Je viens de tester une première fois et j'ai simplement tester ton fichier en passant de 2 manches à 3 manches.
Il tourne continuellement et bien-sûr ne trouve pas la solution.
Marcel
Bonjour Bertrand,
Je viens d'éffectuer plusieurs tests.
Concernant la version V.2 sans doublons partenaires :
en 4 parties, cela fonctionne bien (le temps d'attente le plus long a été de 4 minutes, sinon il variait de 10" à 45").
en 5 parties, par contre cela fonctionne bcp plus lentement et boucle assez bien.
Concernant la version V.2-1 sans doublons partenaires et adversaires :
en 2 parties : c'est ok
en 3 parties et plus : cela ne va plus (boucle)
Cordialement
Marcel
Bonjour,
La version 2 est une version intermédiaire pour tester et visualiser les résultats. Il va falloir remplacer les tableaux excel qui servent de support par des variables tableau VBA.
Cela devrait déjà considérablement accélérer le calcul.
Bertrand