Algorythme et VBA

**Bear the french** · 29/08/2012, 17h46

Bonjour,

Pour moi et après réflexion,

1. Le problème de la rapidité peut être solutionné en grande partie par le passage de l'ensemble des données en variable tableau VBA (jusqu'à 20 fois plus rapide, c'est souvent ce chiffre qui est annoncé)

2. Reste néanmoins un problème de conception : pour qu'Excel trouve un résultat, il faut que ce résultat se traduise par une probabilité.

Reprenons l'énoncé du problème :
5 à 54 inscrits au maximum
5 manches maximum et à chaque manche, il y a un tirage aléatoire : chaque inscrits se voit affecté un numéro d'équipe (soit doublette, soit triplette) et un numéro d'équipe adverse (soit doublette, soit triplette). Jusque là, pas de souci.
Par contre, il faut éviter les doublons : pas deux fois le même équipier ou le même adversaire. Ce que propose la macro de la version en cours : si un doublon est trouvée dans la dernière manche, on boucle pour faire un nouveau tirage de manche... Les éventualités de "non doublon" se rarifiant fortement lorsque l'on est au tirage de la cinquième manche ou lorsque le nombre de participants est plus faible.
Il s'agit bien de probabilités car le tirage est aléatoire mais le résultat est dans un espace fini.
Bref, mes études sont loins
L'univers des possibles au premier tirage =
Le nombre de chances d'être dans une doublette (= nb de doublette x 2) + le nombre de chances d'être dans une triplette (= nb de triplettes x 3)

Dés le deuxième tirage, je bloque pour calculer l'univers des possibles sans coéquipier identique ou adversaire identique sur les deux manches.
Quelqu'un a une idée ?

Bertrand

**MARGAR** · 30/08/2012, 20h19

Bonsoir Bertrand,

J'ai remarqué qu"à chaque tirage, le 1er tirage P1 est pratiquement identique à l'ordre des inscriptions.

Ce qui pose problème, car les joueurs peuvent s"en apercevoir et influencer le résultat de la 1ère manche.

Ci-jointes 3 photos d'écran.

Cordialement.

Marcel

**HopPopPop** · 30/08/2012, 21h47

Bonsoir à tous.

J'ai suivi à peu près ce post, mais suite à la dernière remarque de MARGAR, l'instruction "Randomize" a-t-elle était utilisée ?

Cette dernière permettant lors d'une génération de nombre aléatoires, de démarrer avec une nouvelle série lors de l'appel ; sinon on retombe toujours sur la même série.

Cordialement.

[EDIT] Mea culpa, en relisant.
Elle est utilisée ligne 59 Post 13 pour MARGAR & Ligne 53 Post 37 pour Bear the French.

**Bear the french** · 30/08/2012, 22h36

Bonsoir,

Oui randomize/rnd est utilisé pour classer aléatoirement les inscrits... Avec ce classement, on remplit d'abord les triplettes puis ensuite les doublettes.
S'il y a un bug, je ne vois pas où.
Des tirages presques semblables 3 fois de suite est du domaine du possible... Même si la probabilité est faible.

Marcel : as tu refait des tests ? Toujours les mêmes conclusions ?

Pour le forum : connaissez vous d'autres méthodes de tirage aléatoire que le randomize ?

Bertrand

**MARGAR** · 30/08/2012, 23h12

Bonsoir Bertrand, le forum,

Effectivement, j'ai fait d'autres tests qui aboutissent aux mêmes résultats!
Pour moi, la V 2-0 (plus de doublons entre partenaires) est déjà une version bien aboutie surtout en 4 manches. En 5 manches, cela devient un peu plus lent ( jusqu'à présent avec un max. de 4' d'attente) mais qui fonctionne bien.

Je reviens quand même à ma remarque concernant le résultat du tirage pour la 1ère manche qui reproduit pratiquement l'ordre d'inscription.
Par contre le résultat du même tirage pour les autres manches (2,3,4,5) est très correct et garanti un tirage sans doublons partenaires.

Ne pourrait-on pas, ne pas tenir compte du tirage de la 1ère manche et de prendre en compte que les autres manches (2,3,4,5).

Et éventuellement faire de même avec un tirage 6 manches pour ne prendre en compte 5 manches bien tirées... mais, est-ce POSSIBLE ?

Cordialement

Marcel

**Bear the french** · 30/08/2012, 23h48

Bonsoir,

La manche 1 est la seule qui ne boucle pas puisqu'il n'y a pas de doublons à gérer au premier tirage.

On peut forcer un bouclage aléatoire sur le premier tirage (en partant sur un critère lié à l'heure précise du tirage par exemple).

Pour 6 manches, c'est possible. (mais long)

Bertrand

**MARGAR** · 31/08/2012, 00h05

Bonsoir,

Je viens de refaire un test.

La liste des inscrits par ex. est de 19 Joueurs et va de 001 à 019.

Le résultat du tirage de la 1ère manche donne ce qui suit ( voir ci-joint).

Bonne nuit et à demain

Marcel

**Bear the french** · 31/08/2012, 00h52

Bonsoir,

Bon, ce que cela révèle :
Les tirages aléatoires des plus grands nombres ou des plus petits sont les plus efficaces (ils figurent soit sur la première triplette, soit sur les dernières doublettes).

Peut-être que Randomize gère un aléatoire sous forme de plages/zones. Exemple : si le premier Rnd donne un chiffre entre 0 et 0,5, alors le deuxième donnera un chiffre entre 0,5 et 1 (pour répartir les résultats sur un panel plus large) et ainsi de suite.
Il ne s'agit que d'une théorie et il faudrait expérimenter la chose - ce que je ne peux pas actuellement.
Quelqu'un a une autre idée ?

Bertrand

J'ai trouvé ça en explication chez Microsoft :
"Avant d'appeler Rnd, utilisez l'instruction Randomize sans argument pour initialiser le générateur de nombres aléatoires à partir d'une valeur initiale basée sur l'horloge système."

La solution est peut-être d'introduire un randomize à chaque tirage et non une fois par manche...

Enfin, l'horloge système évoluant sans cesse, on aurait pu se croire à l'abrit de ce problème de récurrence.

Bertrand

Marcel : si tu peux remplacer (et retester merci) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
' Numérotation aléatoire des joueurs
For I = 1 To nbparticipant
 Tablo(I, 2) = Rnd
Next I

Par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
' Numérotation aléatoire des joueurs
For I = 1 To nbparticipant
 Randomize
 Tablo(I, 2) = Rnd
Next I

**MARGAR** · 31/08/2012, 09h16

Bonjour Bertrand, le forum,

Je viens de retester la V 2-0, en changeant le code et rien n'a changé.

Par contre, je viens de tester également mon fichier "CHALLENGE 2012" avec le même nombre de Joueurs inscrits, le tirage de la 1ère manche est tout à fait aléatoire.

Ci-joints, les résultats.

Marcel

**Bear the french** · 31/08/2012, 09h48

Bonjour,

De plus en plus étrange car voilà le code de ton fichier :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Et le code sur la dernière version :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
' Numérotation aléatoire des joueurs
For I = 1 To nbparticipant
 Tablo(I, 2) = Rnd
Next I

Franchement je ne vois pas ce qui diffère.

Bertrand

Ps : les variables tableaux vont accélérer les calculs mais pas résoudre ce problème. C'est pourquoi il nous faut comprendre.

**MARGAR** · 31/08/2012, 14h49

Salut Bertrand, le forum,

Je viens de faire de nouveaux tests et analyse du code de ta V 2-0. Ceux-ci sont, maintenant, concluants...

Dans ton code, j'ai remplacé :

Dim temp As String par Dim temp

Marcel

**Bear the french** · 31/08/2012, 18h49

Bravo, je pense que la transformation du tirage en string faussait sans doute le tri à bulle et la comparaison. Ta modification est bien opportune.
C'est rassurant de comprendre.

Bertrand

Bonsoir,

Comme promis la version V3 : données et calcul sous forme de tableau de variables VBA, disparition des goto, case à cocher pour le choix au départ des doublons + en prime un chronomètre pour comparer les durées de calcul.

Attention, on peut se trouver bloqué si la probabilité de solutions est faible ou inexistante. (dans cette formule, je ne fais un nouveau tirage "que" sur la dernière manche - à voir si nécessaire de faire différemment).

Le code que j'ai essayé de commenter à mesure :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
Option Explicit
Option Base 1
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
 
Sub MARGAR()
 
' --- Déclaration des Variables ---
Dim bigtablo(1 To 54, 1 To 36) As String ' Premiere dimension = Données pour un individu (maxi 54 inscrits)
' Deuxième dimension =
'   1       : Numéro + Prénom
'   2 to 6  : n° d'équipe dans chacune des 5 manches
'   7 to 16 : Désignation des Equipiers (2 par manches donc 10 maximum en 5 manches)
'   17 to 21: n° des rencontres dans chacune des 5 manches
'   22 to 36: Désignation des Adversaires (3 par manches donc 15 maximum en 5 manches)
Dim Tablo 'tableau VBA utilisé pour le tirage au sort des équipes
Dim Tablo2(1 To 9) As Integer 'tableau VBA utilisé pour le tirage au sort des terrains
Dim combinaison As Variant 'tableau combinaisons doublettes/triplettes en fonction du nombre d'inscrits
Dim NbJ As Integer 'nombre total de joueurs
Dim NbManche As Integer ' Nb défini de manches par l'arbitre
Dim i As Integer '1ere variable d'incrémentation
Dim j As Integer '2eme variable d'incrémentation
Dim k As Integer '3eme variable d'incrémentation
Dim l As Integer 'variable d'incrémentation des manches
Dim compteur As Integer 'variable d'incrémentation qui comptabilise le nombre de boucles/de tirages relancés
Dim numero As Integer 'variable de numerotation des joueurs
Dim equipe As Integer 'variable de numerotation des équipes
Dim rencontre As Integer 'variable de numerotation des rencontres
Dim validation As Integer 'Variable de validation des éléments comme non-doublon équipier ou adversaire
Dim temp 'variable de stockage temporaire
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim choixdoublonequipe As Boolean, choixdoublonadverse As Boolean
Dim plage As Range, cel As Range
Dim numequipe As Integer 'varaible temporaire pour gérer l'affichage sous forme de tableur excel
 
' --- initialisation des tableaux de variables ---
Erase bigtablo
 
QueryPerformanceCounter Debut
Application.ScreenUpdating = False
 
Sheets("Saisie").Range("D3:AN55").ClearContents ' on vide le tableau précédent
 
' Remplissage des participants dans le tableau VBA avant tirage aléatoire
Tablo = Sheets("Saisie").Range("B11:B" & Sheets("Saisie").Range("B" & Rows.Count).End(xlUp).Row)
NbJ = UBound(Tablo)
 
' Remplissage des participants dans un tableau VBA pour stocker les données issues du tirage
For i = 1 To NbJ
    bigtablo(i, 1) = Tablo(i, 1)
Next i
 
' on rajoute une dimension pour stocker le tirage associé au joueur
ReDim Preserve Tablo(1 To NbJ, 1 To 2)
 
' On détermine le nombre de doublettes et de triplettes en fonction du nombre d'inscrits et du tableau combinaison ci-dessous
' combinaison(NbJ)(2) = nombre de doublettes
' combinaison(NbJ)(3) = nombre de triplettes
combinaison = Array(Array(1, 0, 0), Array(2, 0, 0), Array(3, 0, 0), Array(4, 2, 0), Array(5, 1, 1), Array(6, 0, 2), _
Array(7, 0, 0), Array(8, 4, 0), Array(9, 3, 1), Array(10, 2, 2), Array(11, 1, 3), Array(12, 0, 4), Array(13, 5, 1), _
Array(14, 4, 2), Array(15, 3, 3), Array(16, 2, 4), Array(17, 1, 5), Array(18, 0, 6), Array(19, 5, 3), Array(20, 4, 4), _
Array(21, 3, 5), Array(22, 2, 6), Array(23, 1, 7), Array(24, 0, 8), Array(25, 5, 5), Array(26, 4, 6), Array(27, 3, 7), _
Array(28, 2, 8), Array(29, 1, 9), Array(30, 0, 10), Array(31, 5, 7), Array(32, 4, 8), Array(33, 3, 9), Array(34, 2, 10), _
Array(35, 1, 11), Array(36, 0, 12), Array(37, 5, 9), Array(38, 4, 10), Array(39, 3, 11), Array(40, 2, 12), Array(41, 1, 13), _
Array(42, 0, 14), Array(43, 5, 11), Array(44, 4, 12), Array(45, 3, 13), Array(46, 2, 14), Array(47, 1, 15), Array(48, 0, 16), _
Array(49, 5, 13), Array(50, 4, 14), Array(51, 3, 15), Array(52, 2, 16), Array(53, 1, 17), Array(54, 0, 18))
 
 
' Sortie du programme si le nombre d'inscrits ne permet pas un tournoi
If combinaison(NbJ)(2) + combinaison(NbJ)(3) = 0 Then: MsgBox "Compte tenu du nombre d'inscrits (" & NbJ & "), il n'y a pas de solutions": Exit Sub
 
' définition du nombre de manches en cellule B2
NbManche = Sheets("Saisie").Range("B3").Value
choixdoublonequipe = Sheets("Saisie").Range("C5").Value
choixdoublonadverse = Sheets("Saisie").Range("C6").Value
 
' on vide les données préalablement renseignées dans les onglets "Manche X"
For l = 1 To 5 Step 1
    Sheets("Manche " & l).Range("A4:I12").ClearContents
Next l
 
Randomize
 
' initialisation du compteur de boucle sur l'ensemble des manches
compteur = 1
 
' On boucle sur chacune des manches
For l = 1 To NbManche
    Do
        ' Numérotation aléatoire des joueurs
        For i = 1 To NbJ Step 1
            Tablo(i, 2) = Rnd
        Next i
 
        ' Tri en fonction de la numérotation des joueurs
        ' tri à bulle en fonction de l'ordre croissant
        For i = 1 To NbJ Step 1
            For j = 1 To NbJ Step 1
                ' Compare 2 tirages de deux joueurs différents
                If Tablo(i, 2) < Tablo(j, 2) Then
                    ' Interverti le n°/prénom et le n° du tirage
                    For k = 1 To 2 Step 1
                        temp = Tablo(i, k)
                        Tablo(i, k) = Tablo(j, k)
                        Tablo(j, k) = temp
                    Next k
                End If
            Next j
        Next i
 
        ' initialisation de la variable numérotation du joueur et autres
        numero = 0
        equipe = 1
        rencontre = 1
        validation = 0
        For i = 1 To NbJ Step 1 ' vide les équipiers et les adversaires (si boucle)
                bigtablo(i, 1 + l) = ""
                bigtablo(i, 5 + (l * 2)) = ""
                bigtablo(i, 6 + (l * 2)) = ""
                bigtablo(i, 16 + l) = ""
                bigtablo(i, 19 + (3 * l)) = ""
                bigtablo(i, 20 + (3 * l)) = ""
                bigtablo(i, 21 + (3 * l)) = ""
        Next i
 
        ' Stockage des tirages, affectation des équipes et des rencontres
        ' On commence par affecter les triplettes
        For i = 1 To combinaison(NbJ)(3) Step 1
            ' j est égal à 3 joueurs = une triplette
            For j = 1 To 3 Step 1
                ' On affecte un numéro par joueur, au fur et à mesure
                numero = numero + 1
                ' On va chercher l'indice correspondant au joueur
                For k = 1 To NbJ Step 1
                    If bigtablo(k, 1) = Tablo(numero, 1) Then
                        ' On affecte le numéro d'équipe
                        bigtablo(k, 1 + l) = equipe
                        ' On affecte le numéro de rencontre
                        bigtablo(k, 16 + l) = rencontre
                    End If
                Next k
 
                ' si 3 coéquipiers, on change d'équipe
                If numero Mod 3 = 0 Then
                    equipe = equipe + 1
                    ' Si nb d'équipes impair, on change de rencontre
                    If (equipe + 1) Mod 2 = 0 Then
                        rencontre = rencontre + 1
                    End If
                End If
            Next j
        Next i
 
        ' Puis on affecte les doublettes
        For i = 1 To combinaison(NbJ)(2) Step 1
            ' j est égal à 2 joueurs = une doublette
            For j = 1 To 2 Step 1
                ' On affecte un numéro par joueur, au fur et à mesure
                numero = numero + 1
                ' On va chercher l'indice correspondant au joueur
                For k = 1 To NbJ Step 1
                    If bigtablo(k, 1) = Tablo(numero, 1) Then
                        ' On affecte le numéro d'équipe
                        bigtablo(k, 1 + l) = equipe
                        ' On affecte le numéro de rencontre
                        bigtablo(k, 16 + l) = rencontre
                    End If
                Next k
 
                ' si 2 coéquipiers, on retranche les joueurs triplettes et on change d'équipe
                If (numero - (3 * combinaison(NbJ)(3))) Mod 2 = 0 Then
                    equipe = equipe + 1
                    ' Si nb d'équipes impair, on change de rencontre
                    If (equipe + 1) Mod 2 = 0 Then
                        rencontre = rencontre + 1
                    End If
                End If
            Next j
        Next i
 
        ' On affecte les coequipiers et les adversaires
        For i = 1 To NbJ Step 1
            For j = 1 To NbJ Step 1
                ' si indice différent et un même n° d'équipe = un équipier
                If i <> j And bigtablo(i, 1 + l) = bigtablo(j, 1 + l) Then
                    If bigtablo(i, 5 + (2 * l)) = "" Then
                        bigtablo(i, 5 + (2 * l)) = bigtablo(j, 1)
                    Else
                        bigtablo(i, 6 + (2 * l)) = bigtablo(j, 1)
                    End If
                End If
                ' On affecte les adversaires = même n° de rencontre mais n° d'équipe différent
                If i <> j And bigtablo(i, 16 + l) = bigtablo(j, 16 + l) And bigtablo(i, 1 + l) <> bigtablo(j, 1 + l) Then
                    If bigtablo(i, 19 + (3 * l)) = "" Then
                        bigtablo(i, 19 + (3 * l)) = bigtablo(j, 1)
                    Else
                        If bigtablo(i, 20 + (3 * l)) = "" Then
                            bigtablo(i, 20 + (3 * l)) = bigtablo(j, 1)
                        Else
                            bigtablo(i, 21 + (3 * l)) = bigtablo(j, 1)
                        End If
                    End If
                End If
            Next j
        Next i
 
        For i = 1 To NbJ Step 1
            ' recherche des doublons dans les équipiers
            If choixdoublonequipe = True Then 'si coché
                For j = 7 To 16 Step 1
                    For k = 7 To 16 Step 1
                        If j <> k And bigtablo(i, j) = bigtablo(i, k) And bigtablo(i, j) <> "" Then
                            validation = 1
                        End If
                    Next k
                Next j
            End If
            ' recherche des doublons dans les adversaires
            If choixdoublonadverse = True Then 'si coché
                For j = 22 To 36 Step 1
                    For k = 22 To 36 Step 1
                        If j <> k And bigtablo(i, j) = bigtablo(i, k) And bigtablo(i, j) <> "" Then
                            validation = 1
                        End If
                    Next k
                Next j
            End If
        Next i
 
    Loop While validation = 1
Next l
 
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
Application.StatusBar = Format((Fin - Debut) / Freq, "0.00 s")
Application.ScreenUpdating = True
 
MsgBox "Le tirage a duré " & Application.StatusBar
 
 
' recopiage des résultats sous feuilles excel
 
'Pour vérification
'Sheets("Saisie").Range("C1:ZZ55").ClearContents ' on vide le tableau précédent
For l = 1 To NbManche Step 1
    For i = 1 To NbJ Step 1
        ' recopiage des n° d'équipe
        Sheets("Saisie").Cells(i + 2, 3 + l).Value = bigtablo(i, l + 1)
        ' recopiage des équipiers
        Sheets("Saisie").Cells(i + 2, 7 + (2 * l)).Value = bigtablo(i, 5 + (2 * l))
        Sheets("Saisie").Cells(i + 2, 8 + (2 * l)).Value = bigtablo(i, 6 + (2 * l))
        ' recopiage des adversaires
        Sheets("Saisie").Cells(i + 2, 21 + (3 * l)).Value = bigtablo(i, 19 + (3 * l))
        Sheets("Saisie").Cells(i + 2, 22 + (3 * l)).Value = bigtablo(i, 20 + (3 * l))
        Sheets("Saisie").Cells(i + 2, 23 + (3 * l)).Value = bigtablo(i, 21 + (3 * l))
        ' recopiage des n° de rencontre
        Sheets("Saisie").Cells(i + 2, 18 + l).Value = bigtablo(i, l + 16)
    Next i
 
    'rempli le tableau "associés" pour plus de
    For i = 1 To rencontre Step 1
        For j = 1 To NbJ Step 1
            If bigtablo(j, l + 16) = i Then
                If Sheets("Manche " & l).Cells(3 + i, 1).Value = "" Then
                    Sheets("Manche " & l).Cells(3 + i, 1).Value = bigtablo(j, 1)
                    numequipe = bigtablo(j, l + 1)
                Else
                    If bigtablo(j, l + 1) = numequipe Then
                        If Sheets("Manche " & l).Cells(3 + i, 2).Value = "" Then
                            Sheets("Manche " & l).Cells(3 + i, 2).Value = bigtablo(j, 1)
                        Else
                            If Sheets("Manche " & l).Cells(3 + i, 3).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 3).Value = bigtablo(j, 1)
                            End If
                        End If
                    Else
                        If Sheets("Manche " & l).Cells(3 + i, 4).Value = "" Then
                            Sheets("Manche " & l).Cells(3 + i, 4).Value = bigtablo(j, 1)
                        Else
                            If Sheets("Manche " & l).Cells(3 + i, 5).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 5).Value = bigtablo(j, 1)
                            Else
                                Sheets("Manche " & l).Cells(3 + i, 6).Value = bigtablo(j, 1)
                            End If
                        End If
                    End If
                End If
            End If
 
        Next j
    Next i
 
 
'affectation des terrains
    Set plage = Sheets("Manche " & l).Range("I4:I" & rencontre + 2)
    i = 0
    For Each cel In plage
        i = i + 1
        Do
            Tablo2(i) = Int(9 * Rnd + 1)
        Loop While Application.CountIf(plage, Tablo2(i))
        cel = Tablo2(i)
    Next cel
 
Next l
 
End Sub

Bertrand

**MARGAR** · 02/09/2012, 09h40

Bonjour Bertrand,

Tests tirage V 3 :

1°) Tirage sans doublons coéquipiers

Que dire... à part que c'est parfait :

Tirage aléatoire excellent
Temps de réponse remarquable

Peut-être, une petite correction à faire concernant l'ordre Triplettes / Doublettes.
Ci-jointes copies d'écrans.

2°) Tirage sans doublons coéquipiers ni adversaires :

Toujours en cours
Temps de réponse : très long surtout au-delà de 3 Manches

En conclusion :

Serait-il possible d'adapter la version sans doublons coéquipiers au fichier "Challenge 2012" ?

Pour la version sans doublons coéquipiers ni adversaires, on peut voir après, si
c'est possible d'améliorer efficacement le temps de réponse.

Bonne journée

Marcel

**Bear the french** · 02/09/2012, 11h33

Bonjour,

Pour les non-doublons adversaires, je pense qu'il faudrait se pencher sur les probabilités et concevoir différemment.

Le code ci dessous doit corriger l'ordre d'apparition doublette/triplette sur les feuilles de Manche :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
Option Explicit
Option Base 1
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
 
Sub MARGAR()
 
' --- Déclaration des Variables ---
Dim bigtablo(1 To 54, 1 To 41) As String ' Premiere dimension = Données pour un individu (maxi 54 inscrits)
' Deuxième dimension =
'   1       : Numéro + Prénom
'   2 to 6  : n° d'équipe dans chacune des 5 manches
'   7 to 16 : Désignation des Equipiers (2 par manches donc 10 maximum en 5 manches)
'   17 to 21: n° des rencontres dans chacune des 5 manches
'   22 to 36: Désignation des Adversaires (3 par manches donc 15 maximum en 5 manches)
'   37 to 41: Désignation si triplette ou doublette
Dim Tablo 'tableau VBA utilisé pour le tirage au sort des équipes
Dim Tablo2(1 To 9) As Integer 'tableau VBA utilisé pour le tirage au sort des terrains
Dim combinaison As Variant 'tableau combinaisons doublettes/triplettes en fonction du nombre d'inscrits
Dim NbJ As Integer 'nombre total de joueurs
Dim NbManche As Integer ' Nb défini de manches par l'arbitre
Dim i As Integer '1ere variable d'incrémentation
Dim j As Integer '2eme variable d'incrémentation
Dim k As Integer '3eme variable d'incrémentation
Dim l As Integer 'variable d'incrémentation des manches
Dim compteur As Integer 'variable d'incrémentation qui comptabilise le nombre de boucles/de tirages relancés
Dim numero As Integer 'variable de numerotation des joueurs
Dim equipe As Integer 'variable de numerotation des équipes
Dim rencontre As Integer 'variable de numerotation des rencontres
Dim mixte As Integer 'variable n° de la rencontre doublette + triplette
Dim validation As Integer 'Variable de validation des éléments comme non-doublon équipier ou adversaire
Dim temp 'variable de stockage temporaire
Dim Debut As Currency, Fin As Currency, Freq As Currency
Dim choixdoublonequipe As Boolean, choixdoublonadverse As Boolean
Dim plage As Range, cel As Range
Dim numequipe As Integer, numequipet As Integer, numequiped As Integer 'variable temporaire pour gérer l'affichage sous forme de tableur excel
 
' --- initialisation des tableaux de variables ---
Erase bigtablo
 
QueryPerformanceCounter Debut
Application.ScreenUpdating = False
 
Sheets("Saisie").Range("D3:AN55").ClearContents ' on vide le tableau précédent
 
' Remplissage des participants dans le tableau VBA avant tirage aléatoire
Tablo = Sheets("Saisie").Range("B11:B" & Sheets("Saisie").Range("B" & Rows.Count).End(xlUp).Row)
NbJ = UBound(Tablo)
 
' Remplissage des participants dans un tableau VBA pour stocker les données issues du tirage
For i = 1 To NbJ
    bigtablo(i, 1) = Tablo(i, 1)
Next i
 
' on rajoute une dimension pour stocker le tirage associé au joueur
ReDim Preserve Tablo(1 To NbJ, 1 To 2)
 
' On détermine le nombre de doublettes et de triplettes en fonction du nombre d'inscrits et du tableau combinaison ci-dessous
' combinaison(NbJ)(2) = nombre de doublettes
' combinaison(NbJ)(3) = nombre de triplettes
combinaison = Array(Array(1, 0, 0), Array(2, 0, 0), Array(3, 0, 0), Array(4, 2, 0), Array(5, 1, 1), Array(6, 0, 2), _
Array(7, 0, 0), Array(8, 4, 0), Array(9, 3, 1), Array(10, 2, 2), Array(11, 1, 3), Array(12, 0, 4), Array(13, 5, 1), _
Array(14, 4, 2), Array(15, 3, 3), Array(16, 2, 4), Array(17, 1, 5), Array(18, 0, 6), Array(19, 5, 3), Array(20, 4, 4), _
Array(21, 3, 5), Array(22, 2, 6), Array(23, 1, 7), Array(24, 0, 8), Array(25, 5, 5), Array(26, 4, 6), Array(27, 3, 7), _
Array(28, 2, 8), Array(29, 1, 9), Array(30, 0, 10), Array(31, 5, 7), Array(32, 4, 8), Array(33, 3, 9), Array(34, 2, 10), _
Array(35, 1, 11), Array(36, 0, 12), Array(37, 5, 9), Array(38, 4, 10), Array(39, 3, 11), Array(40, 2, 12), Array(41, 1, 13), _
Array(42, 0, 14), Array(43, 5, 11), Array(44, 4, 12), Array(45, 3, 13), Array(46, 2, 14), Array(47, 1, 15), Array(48, 0, 16), _
Array(49, 5, 13), Array(50, 4, 14), Array(51, 3, 15), Array(52, 2, 16), Array(53, 1, 17), Array(54, 0, 18))
 
 
' Sortie du programme si le nombre d'inscrits ne permet pas un tournoi
If combinaison(NbJ)(2) + combinaison(NbJ)(3) = 0 Then: MsgBox "Compte tenu du nombre d'inscrits (" & NbJ & "), il n'y a pas de solutions": Exit Sub
 
' définition du nombre de manches en cellule B2
NbManche = Sheets("Saisie").Range("B3").Value
choixdoublonequipe = Sheets("Saisie").Range("C5").Value
choixdoublonadverse = Sheets("Saisie").Range("C6").Value
 
' on vide les données préalablement renseignées dans les onglets "Manche X"
For l = 1 To 5 Step 1
    Sheets("Manche " & l).Range("A4:I12").ClearContents
Next l
 
Randomize
 
' initialisation du compteur de boucle sur l'ensemble des manches
compteur = 1
 
' On boucle sur chacune des manches
For l = 1 To NbManche
    Do
        ' Numérotation aléatoire des joueurs
        For i = 1 To NbJ Step 1
            Tablo(i, 2) = Rnd
        Next i
 
        ' Tri en fonction de la numérotation des joueurs
        ' tri à bulle en fonction de l'ordre croissant
        For i = 1 To NbJ Step 1
            For j = 1 To NbJ Step 1
                ' Compare 2 tirages de deux joueurs différents
                If Tablo(i, 2) < Tablo(j, 2) Then
                    ' Interverti le n°/prénom et le n° du tirage
                    For k = 1 To 2 Step 1
                        temp = Tablo(i, k)
                        Tablo(i, k) = Tablo(j, k)
                        Tablo(j, k) = temp
                    Next k
                End If
            Next j
        Next i
 
        ' initialisation de la variable numérotation du joueur et autres
        numero = 0
        equipe = 1
        rencontre = 1
        validation = 0
        For i = 1 To NbJ Step 1 ' vide les équipiers et les adversaires (si boucle)
                bigtablo(i, 1 + l) = ""
                bigtablo(i, 5 + (l * 2)) = ""
                bigtablo(i, 6 + (l * 2)) = ""
                bigtablo(i, 16 + l) = ""
                bigtablo(i, 19 + (3 * l)) = ""
                bigtablo(i, 20 + (3 * l)) = ""
                bigtablo(i, 21 + (3 * l)) = ""
        Next i
 
        ' Stockage des tirages, affectation des équipes et des rencontres
        ' On commence par affecter les triplettes
        For i = 1 To combinaison(NbJ)(3) Step 1
            ' j est égal à 3 joueurs = une triplette
            For j = 1 To 3 Step 1
                ' On affecte un numéro par joueur, au fur et à mesure
                numero = numero + 1
                ' On va chercher l'indice correspondant au joueur
                For k = 1 To NbJ Step 1
                    If bigtablo(k, 1) = Tablo(numero, 1) Then
                        ' On affecte le numéro d'équipe
                        bigtablo(k, 1 + l) = equipe
                        ' On affecte le numéro de rencontre
                        bigtablo(k, 16 + l) = rencontre
                        ' on affecte le qualificatif d'équipe
                        bigtablo(k, 36 + l) = "Triplette"
                    End If
                Next k
 
                ' si 3 coéquipiers, on change d'équipe
                If numero Mod 3 = 0 Then
                    equipe = equipe + 1
                    ' Si nb d'équipes impair, on change de rencontre
                    If (equipe + 1) Mod 2 = 0 Then
                        rencontre = rencontre + 1
                    End If
                End If
            Next j
        Next i
 
        ' Puis on affecte les doublettes
        For i = 1 To combinaison(NbJ)(2) Step 1
            ' j est égal à 2 joueurs = une doublette
            For j = 1 To 2 Step 1
                ' On affecte un numéro par joueur, au fur et à mesure
                numero = numero + 1
                ' On va chercher l'indice correspondant au joueur
                For k = 1 To NbJ Step 1
                    If bigtablo(k, 1) = Tablo(numero, 1) Then
                        ' On affecte le numéro d'équipe
                        bigtablo(k, 1 + l) = equipe
                        ' On affecte le numéro de rencontre
                        bigtablo(k, 16 + l) = rencontre
                        ' on affecte le qualificatif d'équipe
                        bigtablo(k, 36 + l) = "Doublette"
                    End If
                Next k
 
                ' si 2 coéquipiers, on retranche les joueurs triplettes et on change d'équipe
                If (numero - (3 * combinaison(NbJ)(3))) Mod 2 = 0 Then
                    equipe = equipe + 1
                    ' Si nb d'équipes impair, on change de rencontre
                    If (equipe + 1) Mod 2 = 0 Then
                        rencontre = rencontre + 1
                    End If
                End If
            Next j
        Next i
 
        ' On affecte les coequipiers et les adversaires
        For i = 1 To NbJ Step 1
            For j = 1 To NbJ Step 1
                ' si indice différent et un même n° d'équipe = un équipier
                If i <> j And bigtablo(i, 1 + l) = bigtablo(j, 1 + l) Then
                    If bigtablo(i, 5 + (2 * l)) = "" Then
                        bigtablo(i, 5 + (2 * l)) = bigtablo(j, 1)
                    Else
                        bigtablo(i, 6 + (2 * l)) = bigtablo(j, 1)
                    End If
                End If
                ' On affecte les adversaires = même n° de rencontre mais n° d'équipe différent
                If i <> j And bigtablo(i, 16 + l) = bigtablo(j, 16 + l) And bigtablo(i, 1 + l) <> bigtablo(j, 1 + l) Then
                    If bigtablo(i, 19 + (3 * l)) = "" Then
                        bigtablo(i, 19 + (3 * l)) = bigtablo(j, 1)
                    Else
                        If bigtablo(i, 20 + (3 * l)) = "" Then
                            bigtablo(i, 20 + (3 * l)) = bigtablo(j, 1)
                        Else
                            bigtablo(i, 21 + (3 * l)) = bigtablo(j, 1)
                        End If
                    End If
                End If
            Next j
        Next i
 
        For i = 1 To NbJ Step 1
            ' recherche des doublons dans les équipiers
            If choixdoublonequipe = True Then 'si coché
                For j = 7 To 16 Step 1
                    For k = 7 To 16 Step 1
                        If j <> k And bigtablo(i, j) = bigtablo(i, k) And bigtablo(i, j) <> "" Then
                            validation = 1
                        End If
                    Next k
                Next j
            End If
            ' recherche des doublons dans les adversaires
            If choixdoublonadverse = True Then 'si coché
                For j = 22 To 36 Step 1
                    For k = 22 To 36 Step 1
                        If j <> k And bigtablo(i, j) = bigtablo(i, k) And bigtablo(i, j) <> "" Then
                            validation = 1
                        End If
                    Next k
                Next j
            End If
        Next i
 
    Loop While validation = 1
Next l
 
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
Application.StatusBar = Format((Fin - Debut) / Freq, "0.00 s")
Application.ScreenUpdating = True
 
MsgBox "Le tirage a duré " & Application.StatusBar
 
 
' recopiage des résultats sous feuilles excel
 
'Pour vérification
'Sheets("Saisie").Range("C1:ZZ55").ClearContents ' on vide le tableau précédent
For l = 1 To NbManche Step 1
    For i = 1 To NbJ Step 1
        ' recopiage des n° d'équipe
        Sheets("Saisie").Cells(i + 2, 3 + l).Value = bigtablo(i, l + 1)
        ' recopiage des équipiers
        Sheets("Saisie").Cells(i + 2, 7 + (2 * l)).Value = bigtablo(i, 5 + (2 * l))
        Sheets("Saisie").Cells(i + 2, 8 + (2 * l)).Value = bigtablo(i, 6 + (2 * l))
        ' recopiage des adversaires
        Sheets("Saisie").Cells(i + 2, 21 + (3 * l)).Value = bigtablo(i, 19 + (3 * l))
        Sheets("Saisie").Cells(i + 2, 22 + (3 * l)).Value = bigtablo(i, 20 + (3 * l))
        Sheets("Saisie").Cells(i + 2, 23 + (3 * l)).Value = bigtablo(i, 21 + (3 * l))
        ' recopiage des n° de rencontre
        Sheets("Saisie").Cells(i + 2, 18 + l).Value = bigtablo(i, l + 16)
    Next i
 
    'recherche le numéro d'équipe qui sera mixte = à la fois une doublette et une triplette
    mixte = 0
    If combinaison(NbJ)(3) Mod 2 <> 0 Then
        mixte = Int(combinaison(NbJ)(3) / 2) + 1
    End If
 
    'rempli le tableau "Manche x"
    For i = 1 To rencontre Step 1
        For j = 1 To NbJ Step 1
 
            'tirage sans rencontre mixte triplette/doublette
            If mixte = 0 Then
                If bigtablo(j, l + 16) = i Then
                    If Sheets("Manche " & l).Cells(3 + i, 1).Value = "" Then
                        Sheets("Manche " & l).Cells(3 + i, 1).Value = bigtablo(j, 1)
                        numequipe = bigtablo(j, l + 1)
                    Else
                        If bigtablo(j, l + 1) = numequipe Then
                            If Sheets("Manche " & l).Cells(3 + i, 2).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 2).Value = bigtablo(j, 1)
                            Else
                                If Sheets("Manche " & l).Cells(3 + i, 3).Value = "" Then
                                    Sheets("Manche " & l).Cells(3 + i, 3).Value = bigtablo(j, 1)
                                End If
                            End If
                        Else
                            If Sheets("Manche " & l).Cells(3 + i, 4).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 4).Value = bigtablo(j, 1)
                            Else
                                If Sheets("Manche " & l).Cells(3 + i, 5).Value = "" Then
                                    Sheets("Manche " & l).Cells(3 + i, 5).Value = bigtablo(j, 1)
                                Else
                                    Sheets("Manche " & l).Cells(3 + i, 6).Value = bigtablo(j, 1)
                                End If
                            End If
                        End If
                    End If
                End If
 
            'tirage avec rencontre mixte triplette/doublette
            Else
                If bigtablo(j, l + 16) = i And i <> mixte Then
                    If Sheets("Manche " & l).Cells(3 + i, 1).Value = "" Then
                        Sheets("Manche " & l).Cells(3 + i, 1).Value = bigtablo(j, 1)
                        numequipe = bigtablo(j, l + 1)
                    Else
                        If bigtablo(j, l + 1) = numequipe Then
                            If Sheets("Manche " & l).Cells(3 + i, 2).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 2).Value = bigtablo(j, 1)
                            Else
                                If Sheets("Manche " & l).Cells(3 + i, 3).Value = "" Then
                                    Sheets("Manche " & l).Cells(3 + i, 3).Value = bigtablo(j, 1)
                                End If
                            End If
                        Else
                            If Sheets("Manche " & l).Cells(3 + i, 4).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 4).Value = bigtablo(j, 1)
                            Else
                                If Sheets("Manche " & l).Cells(3 + i, 5).Value = "" Then
                                    Sheets("Manche " & l).Cells(3 + i, 5).Value = bigtablo(j, 1)
                                Else
                                    Sheets("Manche " & l).Cells(3 + i, 6).Value = bigtablo(j, 1)
                                End If
                            End If
                        End If
                    End If
                End If
 
                If bigtablo(j, l + 16) = i And i = mixte Then
                    Select Case bigtablo(j, l + 36)
 
                        Case "Triplette"
                            If Sheets("Manche " & l).Cells(3 + i, 1).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 1).Value = bigtablo(j, 1)
                                numequipet = bigtablo(j, l + 1)
                            Else
                                If bigtablo(j, l + 1) = numequipet Then
                                    If Sheets("Manche " & l).Cells(3 + i, 2).Value = "" Then
                                        Sheets("Manche " & l).Cells(3 + i, 2).Value = bigtablo(j, 1)
                                    Else
                                        If Sheets("Manche " & l).Cells(3 + i, 3).Value = "" Then
                                            Sheets("Manche " & l).Cells(3 + i, 3).Value = bigtablo(j, 1)
                                        End If
                                    End If
                                End If
                            End If
 
                        Case "Doublette"
                            If Sheets("Manche " & l).Cells(3 + i, 4).Value = "" Then
                                Sheets("Manche " & l).Cells(3 + i, 4).Value = bigtablo(j, 1)
                                numequiped = bigtablo(j, l + 1)
                            Else
                                If bigtablo(j, l + 1) = numequiped Then
                                    If Sheets("Manche " & l).Cells(3 + i, 5).Value = "" Then
                                        Sheets("Manche " & l).Cells(3 + i, 5).Value = bigtablo(j, 1)
                                    Else
                                        If Sheets("Manche " & l).Cells(3 + i, 6).Value = "" Then
                                            Sheets("Manche " & l).Cells(3 + i, 6).Value = bigtablo(j, 1)
                                        End If
                                    End If
                                End If
                            End If
 
                    End Select
 
                End If
 
            End If
        Next j
    Next i
 
 
'affectation des terrains
    Set plage = Sheets("Manche " & l).Range("I4:I" & rencontre + 2)
    i = 0
    For Each cel In plage
        i = i + 1
        Do
            Tablo2(i) = Int(9 * Rnd + 1)
        Loop While Application.CountIf(plage, Tablo2(i))
        cel = Tablo2(i)
    Next cel
 
Next l
 
End Sub

Peux-tu nous remettre en ligne ton fichier à adapter (le dernier en date de "CHALLENGE 2012") ? Merci

Bertrand

**MARGAR** · 02/09/2012, 11h54

Merci pour le code, il fonctionne OK.

Ci-joint, fichier "Challenge 2012"

Marcel

**Bear the french** · 02/09/2012, 15h59

Re,

J'ai adapté rapidement.
Par contre j'ai viré pas mal de tes boutons, userforms et macros qui buggaient sur mon ordi (peut-être du à des compléments installés chez toi et pas chez moi).
Quand je n'ai pas le courage de me plonger dedans (ce n'est pas une critique mais c'est fastidieux de suivre le raisonnement d'un tiers), alors je vire c'est plus simple et ça solutionne plus vite les erreurs

Enfin, ce n'est qu'un essai pour te permettre de comprendre comment insérer la nouvelle macro de tirage.

Bertrand

**MARGAR** · 02/09/2012, 21h55

Bonsoir Bertrand,

L'utilisation de ce fichier se fait par un membre du club qui n'est pas doué mais qui est déjà habitué à la présentation et à la manipulation de ce fichier...

Je peux t'aider (suivant mes possibilités) à suivre ensemble le raisonnement à appliquer.

Marcel

**MARGAR** · 03/09/2012, 17h11

Bonjour Bertrand,

Je ne sais quoi dire, je pensais que c'était plus simple que cela, de pouvoir adapter une nouvelle macro à un fichier déjà existant et d'utisation facile.

Continuons alors de perfectionner ta version V 3-0 en y incluant les classements (classement du jour et classement général).

Cordialement

Marcel

**Bear the french** · 03/09/2012, 18h11

Bonsoir Marcel,

Reprends ma dernière version de CHALLENGE 2012 et dis moi ce que j'ai viré d'important et les implications.

Le bouton tirage provoque un tirage avec la liste des inscrits dans l'onglets "liste".
Les boutons "Manche X" ouvrent les formulaires relatifs à chaque manche.
Les boutons "retour au menu" ... reviennent à l'onglet "menu".

Voilà ce que j'ai gardé.

Expliques maintenant ce que tu veux rajouter comme bouton et pour quelle action.

Bertrand

**MARGAR** · 03/09/2012, 19h08

Bonsoir Bertrand,

Il y a qqes petits problèmes qui se présentent :

- dans l'onglet menu, boutons Manche 1,2,..., après avoir encoder les réultats, lorsque l'on clique sur un des boutons, "Valider" par ex : il y a une erreur "9".

- il n'y a pas de macros attachées aux 2 boutons "Classement".

- la date de mise à jour du tournoi ne se fait plus.

Dans l'onglet "Menu", serait-il possible d'activer le bouton " Commencer un nouveau tournoi" vers une liste d'inscription déroulante constituées de tous les membres ?

BAT

Marcel

Algorythme et VBA

Macros et VBA Excel

Discussions similaires

Partager

Partager