Discussion :

[tilowil]

Bonjour à tous,
Avant de vous expliquer mon casse tête, je vais vous faire voir la tête de ma feuille Excel.
Pièce jointe 219869
Je vous explique celle ci.
- Les colonnes A et B correspondent au numéro d'équipe et au numéro dans la feuille (pour mon exemple ils sont identique).
- Les colonnes D, E, F et G correspondent a la répartition des équipes dans la manche. 1 ligne = 1 manche.
- Les colonnes H et I me permettent de traquer les doublons, même si la macro derrière ne doit pas m'en sortir (oui bretelles et ceinture ).
- Les colonnes J, K, L, M, N et O me permettent d'avoir les couples pour le tableau de répartition.
- la colonne P me permet de connaitre les ligne contenant le numéro d'équipe que je recherche (en T28).
- les colonnes Q et R me permettent de compter le nombre de fois qu'une équipe est présente.
- les colonnes T à AR me permettent de voir la répartition et le nombre de fois que chaque couple se rencontre.
- la cellule AU5 me permet de définir le nombre d'équipes a calculer dans la macro. Le nombre d’équipes pour ce cas est compris entre 9 et 20.
- Le bouton Remplissage est connecté à la Macro VBA Remplissage.

Quelques formules de la feuille :
Pièce jointe 219880

Pièce jointe 219881

Voici maintenant le code de la macro. Merci de votre indulgence.

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
 
    Dim NbMaxEquipe As Integer
    Dim CptEquipe1 As Integer
    Dim CptEquipe2 As Integer
    Dim CptEquipe3 As Integer
    Dim CptEquipe4 As Integer
    Dim Cpt2 As Integer
    Dim CptLigne As Integer
    Dim RowStart As Integer
    Dim ColE1 As Integer
    Dim ColE2 As Integer
    Dim ColE3 As Integer
    Dim ColE4 As Integer
    Dim IncLigne As Integer
    Dim Trouve As Boolean
    Dim Premier As Boolean
    Dim NbLigne As Integer
    Dim Jeu As Integer
    Dim Grille(4, 10000) As Integer
    Dim Ordre(4, 10000) As Integer
    Dim NbPartie(1000) As Integer
    Dim GrilleFinale(4, 10000) As Integer
    Dim Comptage() As Integer
 
 
Sub Remplissage()
 
    Randomize
 
    Jeu = InputBox("Combien d'équipes en même temps (4) ?", "Type de jeu", 4)
 
    RowStart = 2
    ColE1 = 4
    ColE2 = 5
    ColE3 = 6
    ColE4 = 7
    ' Je recupère le nombre max d'equipes
    Range("AU5").Select
    NbMaxEquipe = ActiveCell.FormulaR1C1
    ReDim Comptage(NbMaxEquipe)
    NbLigne = NbMaxEquipe * 3
    CreationGrille NbMaxEquipe, Jeu
    ClassementGrille
    CreationGrilleFinale
    EcritureGrilleFinale
 
End Sub
 
Private Sub CreationGrille(NbMaxEquipe As Integer, TypeJeu As Integer)
 
    For Cpt1 = 0 To TypeJeu
      For Cpt2 = 0 To 10000
        Grille(Cpt1, Cpt2) = 0
      Next Cpt2
    Next Cpt1
    IncLigne = 0
    Range("A2:B38000").ClearContents
    Range("D2:G38000").ClearContents
 
    For CptEquipe1 = 1 To NbMaxEquipe
        'J'ecris les equipes et leur numéros associés
        ActiveSheet.Cells(RowStart + CptEquipe1 - 1, 1) = CptEquipe1
        ActiveSheet.Cells(RowStart + CptEquipe1 - 1, 2) = CptEquipe1
        ' Création de toutes les combinaisons
        For Cpt2 = 1 To NbMaxEquipe
            Trouve = True
            Iteration = 0
            Do Until (Trouve = False Or Iteration = 1000)
               CptEquipe2 = CInt(Int((NbMaxEquipe * Rnd()) + 1))
               For Cpt = 1 To 1000
               Next Cpt
               CptEquipe3 = CInt(Int((NbMaxEquipe * Rnd()) + 1))
               CptEquipe4 = CInt(Int((NbMaxEquipe * Rnd()) + 1))
 
               If (CptEquipe1 <> CptEquipe2 And CptEquipe1 <> CptEquipe3 And CptEquipe1 <> CptEquipe4 And CptEquipe2 <> CptEquipe3 And CptEquipe2 <> CptEquipe4 And CptEquipe3 <> CptEquipe4) Then
                  For CptLigne = 0 To IncLigne
                      If Not ((CptEquipe1 = Grille(0, CptLigne) Or CptEquipe1 = Grille(1, CptLigne) Or CptEquipe1 = Grille(2, CptLigne) Or CptEquipe1 = Grille(3, CptLigne)) _
                      And (CptEquipe2 = Grille(0, CptLigne) Or CptEquipe2 = Grille(1, CptLigne) Or CptEquipe2 = Grille(2, CptLigne) Or CptEquipe2 = Grille(3, CptLigne)) _
                      And (CptEquipe3 = Grille(0, CptLigne) Or CptEquipe3 = Grille(1, CptLigne) Or CptEquipe3 = Grille(2, CptLigne) Or CptEquipe3 = Grille(3, CptLigne)) _
                      And (CptEquipe4 = Grille(0, CptLigne) Or CptEquipe4 = Grille(1, CptLigne) Or CptEquipe4 = Grille(2, CptLigne) Or CptEquipe4 = Grille(3, CptLigne))) Then
                         Trouve = False
                      Else
                         Trouve = True
                         Exit For
                      End If
                  Next CptLigne
               End If
               Iteration = Iteration + 1
            Loop
 
            If Not Trouve Then
               ' les 4 valeurs sont différentes alors on les ecrit
               Grille(0, IncLigne) = CptEquipe1
               Grille(1, IncLigne) = CptEquipe2
               Grille(2, IncLigne) = CptEquipe3
               Grille(3, IncLigne) = CptEquipe4
 
               IncLigne = IncLigne + 1
            End If
            If Iteration = 1000 Then
               ActiveSheet.Cells(RowStart + IncLigne, ColE1) = CptEquipe
               ActiveSheet.Cells(RowStart + IncLigne, ColE2) = "X"
               ActiveSheet.Cells(RowStart + IncLigne, ColE3) = "X"
               ActiveSheet.Cells(RowStart + IncLigne, ColE4) = "X"
               IncLigne = IncLigne + 1
            End If
        Next Cpt2
    Next CptEquipe1
    IncLigne = IncLigne - 1
End Sub
 
Private Sub ClassementGrille()
  Dim ArraySort(4) As Integer
 
  For Cpt = 0 To IncLigne
    ArraySort(0) = Grille(0, Cpt)
    ArraySort(1) = Grille(1, Cpt)
    ArraySort(2) = Grille(2, Cpt)
    ArraySort(3) = Grille(3, Cpt)
 
    For i = LBound(ArraySort) To UBound(ArraySort)
         For j = i + 1 To UBound(ArraySort)
             If ArraySort(i) > ArraySort(j) Then
                 SrtTemp = ArraySort(j)
                 ArraySort(j) = ArraySort(i)
                 ArraySort(i) = SrtTemp
             End If
         Next j
     Next i
    Ordre(0, Cpt) = ArraySort(0)
    Ordre(1, Cpt) = ArraySort(1)
    Ordre(2, Cpt) = ArraySort(2)
    Ordre(3, Cpt) = ArraySort(3)
Next Cpt
 
End Sub
 
Private Sub CreationGrilleFinale()
  Dim Utilise() As Integer
  Dim OkToInsert As Boolean
  Dim LignePrecedente As String
  Dim DejaUtilise As Boolean
  Dim Ok As Boolean
  Dim Itq As Integer
 
  Itq = 0
Debut:
  ReDim Utilise(0)
 
  For Cpt = 0 To UBound(Comptage)
    Comptage(Cpt) = 0
  Next Cpt
 
  For Cpt = 0 To IncLigne
    If Cpt = 0 Then
      idx = CInt(Int((IncLigne * Rnd()) + 1))
      GrilleFinale(0, Cpt) = Grille(0, idx)
      GrilleFinale(1, Cpt) = Grille(1, idx)
      GrilleFinale(2, Cpt) = Grille(2, idx)
      GrilleFinale(3, Cpt) = Grille(3, idx)
      Comptage(Grille(0, idx)) = Comptage(Grille(0, idx)) + 1
      Comptage(Grille(1, idx)) = Comptage(Grille(1, idx)) + 1
      Comptage(Grille(2, idx)) = Comptage(Grille(2, idx)) + 1
      Comptage(Grille(3, idx)) = Comptage(Grille(3, idx)) + 1
      ReDim Preserve Utilise(UBound(Utilise) + 1)
      Utilise(UBound(Utilise) - 1) = idx
      LignePrecedente = CStr(Grille(0, idx)) & "," & CStr(Grille(1, idx)) & "," & CStr(Grille(2, idx)) & "," & CStr(Grille(3, idx))
    Else
      OkToInsert = False
      If IsOdd(Cpt) Then
        For idxOdd = 0 To IncLigne
          DejaUtilise = False
          For CptUtilise = LBound(Utilise) To UBound(Utilise) - 1
            If idxOdd = Utilise(CptUtilise) Then
              DejaUtilise = True
              Exit For
            End If
          Next CptUtilise
          If Not DejaUtilise Then
            'On extrait les 4 valeurs
            A = Grille(0, idxOdd)
            B = Grille(1, idxOdd)
            C = Grille(2, idxOdd)
            D = Grille(3, idxOdd)
            'Teste des valeurs avec la ligne finale précedente
            If (InStr(1, LignePrecedente, A) <> 0) Or (InStr(1, LignePrecedente, B) <> 0) Or (InStr(1, LignePrecedente, C) <> 0) Or (InStr(1, LignePrecedente, D) <> 0) Then
              OkToInsert = False
            Else
              OkToInsert = True
              Exit For
            End If
          End If
        Next idxOdd
        idx = idxOdd
      Else
        For idxEven = IncLigne To 0 Step -1
          DejaUtilise = False
          For CptUtilise = LBound(Utilise) To UBound(Utilise) - 1
            If idxEven = Utilise(CptUtilise) Then
              DejaUtilise = True
              Exit For
            End If
          Next CptUtilise
          If Not DejaUtilise Then
            'On extrait les 4 valeurs
            A = Grille(0, idxEven)
            B = Grille(1, idxEven)
            C = Grille(2, idxEven)
            D = Grille(3, idxEven)
            'Teste des valeurs avec la ligne finale précedente
            If (InStr(1, LignePrecedente, A) <> 0) Or (InStr(1, LignePrecedente, B) <> 0) Or (InStr(1, LignePrecedente, C) <> 0) Or (InStr(1, LignePrecedente, D) <> 0) Then
              OkToInsert = False
            Else
              OkToInsert = True
              Exit For
            End If
          End If
        Next idxEven
        idx = idxEven
      End If
      If OkToInsert Then
        GrilleFinale(0, Cpt) = Grille(0, idx)
        GrilleFinale(1, Cpt) = Grille(1, idx)
        GrilleFinale(2, Cpt) = Grille(2, idx)
        GrilleFinale(3, Cpt) = Grille(3, idx)
        Comptage(Grille(0, idx)) = Comptage(Grille(0, idx)) + 1
        Comptage(Grille(1, idx)) = Comptage(Grille(1, idx)) + 1
        Comptage(Grille(2, idx)) = Comptage(Grille(2, idx)) + 1
        Comptage(Grille(3, idx)) = Comptage(Grille(3, idx)) + 1
        ReDim Preserve Utilise(UBound(Utilise) + 1)
        Utilise(UBound(Utilise) - 1) = idx
        LignePrecedente = CStr(Grille(0, idx)) & "," & CStr(Grille(1, idx)) & "," & CStr(Grille(2, idx)) & "," & CStr(Grille(3, idx))
        If Cpt = NbLigne - 1 Then
          Exit For
        End If
      Else
        Exit For
      End If
    End If
  Next Cpt
  If UBound(Utilise) - 1 < NbLigne - 1 Then
    Itq = Itq + 1
    If Itq = 10000 Then
      CreationGrille NbMaxEquipe, Jeu
      ClassementGrille
      Itq = 0
    End If
    GoTo Debut
  Else
    Ok = True
    For Cpt = 1 To UBound(Comptage)
      If Comptage(Cpt) <> (Jeu * 3) Then
        Ok = False
        Exit For
      End If
    Next Cpt
    If Not Ok Then
      'CreationGrille NbMaxEquipe, Jeu
      'ClassementGrille
      GoTo Debut
    End If
  End If
End Sub
Private Sub EcritureGrilleFinale()
  For Cpt = 0 To NbLigne - 1
    ' les 4 valeurs sont différentes alors on les ecrit
    ActiveSheet.Cells(RowStart + Cpt, ColE1) = GrilleFinale(0, Cpt)
    ActiveSheet.Cells(RowStart + Cpt, ColE2) = GrilleFinale(1, Cpt)
    ActiveSheet.Cells(RowStart + Cpt, ColE3) = GrilleFinale(2, Cpt)
    ActiveSheet.Cells(RowStart + Cpt, ColE4) = GrilleFinale(3, Cpt)
  Next Cpt
End Sub
 
Private Function IsOdd(value)
  IsOdd = (value Mod 2 = 1)
End Function

Maintenant, vous avez tout en main. Il ne me reste plus qu'a vous expliquer pourquoi je lance un topic pour demander de l'aide.
En premier les règles de gestion :
- Le nombre d'équipes admissibles est compris entre 9 et 20 pour des manches avec 4 équipes par manches.
- Pour chaque équipe, il y a forcement au moins 1 manche de repos entre 2 manches actives.
- Le nombre de manches jouées par équipe est égale au nombre d’équipe par manche x 3 (ici 4 equipes par manche donc 4x3= 12 manches à jouer) pas plus, pas moins.
- La répartition des couples doit être la plus proche possible (un delta de 1 est accepté)
- le nombre de manche est égal au nombre d’équipe x 3 (ici 9 équipes donc 9x3= 27 manches) pas plus, pas moins.

En sachant qu'ensuite je vais devoir adapter ce calcul pour des manches à 3 équipes (7 équipes à 20 équipes).

Mon système fonctionne a peu près bien avec 9 équipes en manche de 4. A peu près car la répartition laisse encore un peu à désirer .

Mais si je demande 10 équipes, je n'obtiens aucun résultat et excel finit par ne plus répondre.

Si quelqu'un a des idées, des solutions, un Algorithme pour un Nul, je suis intéressée. Il y a surement une solution simple que mon esprit de retraité ne voit pas.

J'ai jusqu'à début Décembre pour trouver une solution. Je continu en parallèle a chercher de mon coté et si je trouve je posterai une réponse ici.

Merci de votre attention et de votre aide.

[tilowil]

un petit Up après 20 jours sans le moindre messages, idées ou commentaire.

problème insoluble ? d'autres personnes recherchent de leur coté, mais n'ont rien trouvé ? ce genre de problème n’intéresse personne ?

De mon coté, je suis toujours en train de chercher mais je plante excel toujours avec mes 10 équipes.

Merci de votre aide.

[Menhir]

Pour ne pas te laisser sans réponse et sans vouloir paraitre agressif (mais sans langue de bois non plus), il faut que tu comprennes que ce que tu demandes est un développement complet qui exige plusieurs heures de travail.
Honnêtement, bien peu de participants à ce forum seront prêts à consacrer ce temps à un inconnu qui les aura oublié 10 min après avoir obtenu ce qu'il souhaite. Personnellement, tu comprends bien que je préfère passer mes soirées à m'occuper de ma famille.

Je te dis ça uniquement pour essayer de te faire comprendre le pourquoi de cette absence de réponses.

[tilowil]

Merci Menhir, pour cette réponse, que je comprends.

Hormis que je ne demande pas un développement, mais simplement un peu d'aide pour comprendre pourquoi mon système plantait quand je faisais le calcul pour 10 équipes. C'est pour ça que j'ai tout expliqué, car le principe n'est pas simple.
Je ne demande a aucun moment une solution clé en main, mais un indice, une astuce, une solution à mon problème de plantage.

Maintenant, comme je l'ai dit, j'ai continué à chercher en parallèle et j'ai trouvé une solution ce matin, que je suis en train de mettre en oeuvre.

Par contre il est vrai que je ne sert pas souvent d'excel, mais de la à avoir ce genre de retour, je trouve dommage de ne pas permettre aux nouveaux qui viennent sur ce forum pour avoir de l'aide de les ignorer, car vous pensez qu'après avoir eu la solution on oublie le Forum et ses utilisateurs. Heureusement que je ne réagit pas comme ça sur les autres forums ou j'officie, que la personne est 1 message a son compteur ou 7000 il n'y a pas de différence pour moi. Je vois le forum comme un lieu d'entraide et de partage.

Bref, sans agressivité de ma part non plus, mais sans langue de bois, j'espère que vous saurez évoluer et vous ouvrir aux nouveaux.

En ce qui me concerne le sujet est clos et ce topic peut être fermé, car j'ai ma solution, qui ne vous intéressera surement pas, vu l’intérêt portée à ma demande d'aide.

Une dernière chose, j'adresse un grand merci à Pierre Fauconnier pour avoir réorienter mon topic au bon endroit.

Cordialement.

[Menhir]

je trouve dommage de ne pas permettre aux nouveaux qui viennent sur ce forum pour avoir de l'aide de les ignorer

Si tu prends la peine de lire les autres discutions de ce forum, tu pourras constater qu'il y a énormément de nouveaux qui obtiennent de l'aide ici.
Ils constituent même l'écrasante majorité de ceux qui font des demandes.

[Jean-Philippe André]

Salut,

quelques elements qui me sautent aux yeux dans ton code (erreurs ? oublis ? autres explications ?)

Tu as une boucle dans le vide

Code :

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

1
2
For Cpt = 1 To 1000
Next Cpt

Comme le souligne Menhir, fournir autant de lignes de code = attendre des autres membres de tout lire = du temps a passer.

Afin d'optimiser tes chances de reponses, quelques pistes :
- placer des points d'arrets dans ton code (F9) pour voir quelle partie du code part en sucette
- decouper chaque etape et constater celle qui part en sucette
- commenter ton code, notamment pour expliquer l'interet et l'objectif de certains blocs de code (tu as deja mis des commentaires, mais trop disparates pour que l'on comprenne tout d'un coup d'oeil)
- utilise une nomenclature pour nommer tes variables (leur nom est explicite, mais de quel type de variable s'agit-il ?) avec des b pour boolean, i pour integerm, etc. par exemple.

Le chemin vers la solution est long et perilleux, mais on apprend ainsi =]