Élaboration automatique d'un jeu de domino à partir des pièces uniques

**jeanbaptist05** · 21/06/2018, 12h04

Bonjour à la communauté,

Je vais essayer d'être le plus clair possible, j'essaye de trouver une logique de code qui me permette, à partir des éléments de l'image numéro n°1 (liens verts entre Entrée/Sortie et liens oranges entre Sortie/Entrée) d'automatiser la construction de l'arbre des Entrées/Sorties (image n°2). Cela me permettant de récupérer un ordre de traitement des entrées et sorties en fonction de leur position (image n°3). J'insiste sur le fait que mon but est d'automatiser le traitement et non pas de le faire analytiquement.

Mon idée est de prendre le premier "domino" vert de la liste ("E1, S1" dans l'exemple de l'image n°1) comme base et de dérouler la logique domino (comme sur image n°2) vers la droite pour arriver jusqu'à la sortie finale (S25 dans l'exemple sur l'image n°2). En effet, pour une valeur de sortie d'un domino vert donnée, il n'y qu'un seul domino orange qui correspond. Cela permet de trouver le bout de la ficelle en somme.

De la sortie finale, le but est de repartir vers la gauche en étant exhaustif cette fois-ci et en affectant aux entrées et sorties considérées un niveau correspondant à leur place (S25 --> niveau 1, E33 --> niveau 2, etc.). Je précise que l'ordre dans un niveau n'a aucune importance.

J'avais aussi pensé à mettre en place un système de compteur prenant en compte le nombre de dominos à traiter car il faut que l'automatisation prenne en compte la construction et le traitement de plusieurs branches (2ème branche de l'exemple : image n°4) donc d'éviter l'oubli de dominos. Je précise que l'utilisation d'un domino dans une branche traitée antérieurement ne doit pas empêcher l'utilisation de ce même domino dans une branche future (besoin de traiter le domino dans son niveau le plus bas s'il apparaît à plusieurs niveaux).

Quelques précisions :

Les cellules oranges "CU1" "CU2" et "EX" ne sont pas à traiter dans l'automatisation de l'arbre car ces infos seront récupérés via les dominos verts
Les cellules jaunes notifées "REPET'" indique qu'il y a répétition d'un même schéma cependant ce même schéma devra être pris en compte dans l'automatisation car son niveau peut être inférieur à un précédent

image n°1 :
Nom : Liste entrées sorties.PNG
Affichages : 480
Taille : 20,4 Ko

image n°2 :
Nom : Branche.PNG
Affichages : 421
Taille : 39,4 Ko

image n°3 :
Nom : Résultat.PNG
Affichages : 399
Taille : 6,8 Ko

image n°4 :
Nom : Autre branche.PNG
Affichages : 394
Taille : 4,6 Ko

Mon questionnement vis à vis de la communauté est multiple. Tout d'abord, ma logique est-elle rélisable compte-tenu de mes contraintes ? Pensez-vous à une logique de code plus simple ? Plus largement ce que je veux faire est-il réalisable ?

J'ai commencé à coder la reconnaissance des entrées et sorties notées sur les dominos afin de les assembler en partant du vert, 1er de la liste et je suis actuellement en train d'essayer de faire une boucle me permettant d'arriver à S25 dans l'exemple. Encore beaucoup de travail j'en ai conscience !

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
 
Sub liens()
 
increm4 = 1
 
 
    '1ERE ITERATION
 
    Cells(200, 200) = Cells(45, 7)
 
 
        'J'ai ValsortieV = SX ou SXX
        If InStr(Cells(200, 200), ",") = 3 And Len(Cells(200, 200)) = 6 Then
        ValsortieV = Mid(Cells(200, 200), 5, 2)
        ElseIf InStr(Cells(200, 200), ",") = 3 And Len(Cells(200, 200)) = 7 Then
        ValsortieV = Mid(Cells(200, 200), 5, 3)
        ElseIf InStr(Cells(200, 200), ",") = 4 And Len(Cells(200, 200)) = 7 Then
        ValsortieV = Mid(Cells(200, 200), 6, 2)
        ElseIf InStr(Cells(200, 200), ",") = 4 And Len(Cells(200, 200)) = 8 Then
        ValsortieV = Mid(Cells(200, 200), 6, 3) 'Valeur sortie de la 1ère case verte
        End If                                   'récupérée dans ValsortieV
 
 
        'J'ai ValsortieO = SX ou SXX
        For i = 0 To Cells(43, 9) - 1 'Pour toutes les cases orange
 
        If InStr(Cells(45 + i, 9), ",") = 3 Then 'Recherche valeur de sortie orange
        ValsortieO = Mid(Cells(45 + i, 9), 1, 2)
        ElseIf InStr(Cells(45 + i, 9), ",") = 4 Then
        ValsortieO = Mid(Cells(45 + i, 9), 1, 3) 'Valeur sortie de case orange récupérée
        End If                                'dans ValsortieO
 
 
        If ValsortieO = ValsortieV Then 'Si sortie correspondante trouvée fait ça :
        Cells(200 + increm4, 200 + increm4) = Cells(45 + i, 9)
        increm4 = increm4 + 1
        End If
        Next i 'Sinon continue de chercher avec la prochaine case
 
                        'ETAT : 1ère case orange rattachée
 
 
    'N IEME ITERATION
 
 
        'J'ai ValentreeO = Ex ou EXX
        If InStr(Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 6 Then
        ValentreeO = Mid(Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 2)
        ElseIf InStr(Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
        ValentreeO = Mid(Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 3)
        ElseIf InStr(Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
        ValentreeO = Mid(Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 2)
        ElseIf InStr(Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 8 Then
        ValentreeO = Mid(Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 3)
        End If       'Valeur entrée de case orange dans ValentreeO
 
        For i = 0 To Cells(43, 7) - 1 'Pour toutes les cases vertes
        If InStr(Cells(45 + i, 7), ",") = 3 Then 'Recherche valeur d'entrée verte correspondante
        ValsortieO = Mid(Cells(45 + i, 9), 1, 2)
        ElseIf InStr(Cells(45 + i, 9), ",") = 4 Then
        ValsortieO = Mid(Cells(45 + i, 9), 1, 3) 'Valeur sortie de case orange récupérée
        End If                                'dans ValsortieO
        Next
 
 
 
 
 
 
End Sub

J'ai arbitrairement commencé la 1ère branche en cells(200, 200), la cells(43,9) correspond au nombre de domino orange à traiter et la cells(43,7) aux verts. Les listes commencent en cells(45,7) et cells(45, 9).

Je dis d'avance merci à toute personne qui tentera de me repondre car j'ai conscience de la singularité de mon problème. Je serai ravi d'apporter des précisions si je n'ai pas été assez clair.

Invité · 21/06/2018, 13h46

Bonjour,
je ne sais pas si c'est la solution, mais regarde du coté des carte mental.

**jeanbaptist05** · 21/06/2018, 14h00

Envoyé par dysorthographie

Bonjour,
je ne sais pas si c'est la solution, mais regarde du coté des carte mental.

Bonjour,

Tout d'abord, merci pour ta réponse !
J'ai regardé un peu du côté des cartes mentales mais malheuresement je n'ai trouvé que des propositions de logiciels pour en faire et non des applications sur VBA. Je continue de chercher. Encore merci et bonne fête de la musique.

Invité · 21/06/2018, 16h43

en fait il te faudra bien un gratuiciel pour le visualiser, mais le contenu est proche du xml.

Code fichier toto.mm :

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

1
2
3
4
5
6
7
8
<map version="1.0.1"><!-- To view this file, download free mind mapping software FreeMind from http://freemind.sourceforge.net -->
<node CREATED="1527765660400" ID="ID_1762144990" MODIFIED="1527765846277" TEXT="toto">
<node CREATED="1527765846277" ID="ID_1837809211" MODIFIED="1527765870075" POSITION="right" TEXT="rr">
<node CREATED="1527765660400" ID="ID_216308094" MODIFIED="1527765660400" TEXT="Nouvelle carte mentale"/>
<node CREATED="1527765870075" ID="ID_1716210851" MODIFIED="1527765873747" TEXT="rr"/>
</node>
</node>
</map>

**jeanbaptist05** · 21/06/2018, 17h31

Envoyé par dysorthographie

en fait il te faudra bien un gratuiciel pour le visualiser, mais le contenu est proche du xml.

Code fichier toto.mm :

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

1
2
3
4
5
6
7
8
<map version="1.0.1"><!-- To view this file, download free mind mapping software FreeMind from http://freemind.sourceforge.net -->
<node CREATED="1527765660400" ID="ID_1762144990" MODIFIED="1527765846277" TEXT="toto">
<node CREATED="1527765846277" ID="ID_1837809211" MODIFIED="1527765870075" POSITION="right" TEXT="rr">
<node CREATED="1527765660400" ID="ID_216308094" MODIFIED="1527765660400" TEXT="Nouvelle carte mentale"/>
<node CREATED="1527765870075" ID="ID_1716210851" MODIFIED="1527765873747" TEXT="rr"/>
</node>
</node>
</map>

Merci pour ta proposition mais malheuresement, je ne maîtrise pas le XML. Cependant je réussis à avancer dans mon code, ma logique à l'air fonctionnelle même si non optimisée. Je pense publier mon code une fois terminé afin de le mettre à disposition.

Merci encore pour le temps que tu m'as consacré.

**jeanbaptist05** · 04/07/2018, 11h19

J'ai terminé, le code est fonctionnel pour ma part avec mes données d'entrées. Le principe est de contruire chaque branche en partant de la sortie et de récupérer l'ordre. J'espère que ce contenu pourra aider quelqu'un ! Merci à tous pour votre aide.

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
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
 
 
 
 
Sub DeclVarPublicPourMacro()
 
Feuil1.Unprotect
 
Dim wApp As Word.Application
Dim wDoc As Word.Document
 
 
'I]    COMPTEUR NB COMPOSANT
 
'Variable pour copier coller les intitulés "composants" des colonnes
'et variable pour stocker le nombre de composant
 
Dim increm As Integer
 
increm = 0
compteurcomp = 0
 
'Déplacement des cellules
 
For i = 5 To 2000
 
    If Not IsEmpty(Feuil6.Cells(2, i)) Then
        Feuil6.Cells(2 + increm, 2100) = Feuil6.Cells(2, i)
        increm = increm + 1
    End If
Next
 
'Supression des doublons
 
Feuil6.Range("$CBT$1:$CBT$2000").RemoveDuplicates Columns:=1, Header:= _
xlNo
 
'Comptage du nombre de cellule après supression des doublons
'donc --> comptage nb composants
 
For i = 2 To 2000
    If Not IsEmpty(Feuil6.Cells(i, 2100)) Then
        compteurcomp = compteurcomp + 1
    End If
Next
Feuil6.Columns("CBT:CBT").ClearContents
'FIN COMPTEUR
 
 
'COMPTEUR NB SORTIES
compteurso = 0
 
For i = 5 To 2000
 
    If Not IsEmpty(Feuil6.Cells(4, i)) Then
        compteurso = compteurso + 1
    End If
Next
'FIN COMPTEUR
 
 
'AFFECTE NOM AUX SORTIES
For h = 1 To compteurso
    celluleu = "S" & h
    Feuil6.Cells(1, h + 4) = celluleu
Next
'FIN
 
 
'COMPTEUR NB declentrées
compteuren = 0
 
For i = 5 To 2000
 
    If Not IsEmpty(Feuil6.Cells(i, 4)) Then
        compteuren = compteuren + 1
    End If
Next
'FIN COMPTEUR
 
 
 
'AFFECTE NOM AUX ENTREÉS
For g = 1 To compteuren
    celluleu = "E" & g
    Feuil6.Cells(g + 4, 1) = celluleu
Next
'FIN
 
'AFFECTE CX AUX EN ET SO
Dim initcomp As Byte
Dim celluleu2 As String
'SORTIES
initcomp = 1
celluleu = "C" & initcomp
Feuil6.Cells(5 + compteuren, 5) = celluleu
 
For d = 1 To compteurso - 1
    If Feuil6.Cells(2, d + 4) = Feuil6.Cells(2, d + 5) Then
        celluleu2 = "C" & initcomp
        Feuil6.Cells(5 + compteuren, d + 5) = celluleu2
    Else
        initcomp = initcomp + 1
        celluleu2 = "C" & initcomp
        Feuil6.Cells(5 + compteuren, d + 5) = celluleu2
    End If
Next
 
'ENTREÉS
initcomp = 1
celluleu = "C" & initcomp
Feuil6.Cells(5, 5 + compteurso) = celluleu
 
For d = 1 To compteuren - 1
    If Feuil6.Cells(d + 4, 2) = Feuil6.Cells(d + 5, 2) Then
        celluleu2 = "C" & initcomp
        Feuil6.Cells(d + 5, 5 + compteurso) = celluleu2
    Else
        initcomp = initcomp + 1
        celluleu2 = "C" & initcomp
        Feuil6.Cells(d + 5, 5 + compteurso) = celluleu2
    End If
Next
'FIN
 
 
 
 
 
 
'   2)PRISE EN COMPTE DU PROBABLEMENT INCRIMINÉ = 3
 
'       2)a)RECHERCHE ET RÉCUPÉRATION DES LIENS ENTRE FLUX D'ÉQUIPEMENTS
 
'Si le flux sortant est défaillant et que le flux
'entrant correspondant est noté neutre
'afficher le flux entrant en probablement incriminé
 
'Avoir les liens verts (internes équipements renseignées par les experts)
Dim increm3 As Integer
increm3 = 0
 
For i = 1 To compteurso
    For j = 1 To compteuren
 
        If IsEmpty(Feuil6.Cells(j + 4, i + 4)) = False Then
            Feuil3.Cells(45 + increm3, 7) = Feuil6.Cells(j + 4, 1) & ", " & Feuil6.Cells(1, i + 4)
            increm3 = increm3 + 1
        End If
    Next j
Next i
 
Feuil3.Cells(43, 7) = increm3
 
'Avoir les liens oranges (externes équipements --> renvoi aux connectiques)
 
increm3 = 0
 
For i = 1 To compteurso
    For j = 1 To compteuren
 
    cherchentree = Feuil6.Cells(j + 4, 3) & Feuil6.Cells(j + 4, 4)
    cherchesortie = Feuil6.Cells(3, i + 4) & Feuil6.Cells(4, i + 4)
 
        If cherchentree = cherchesortie Then
            Feuil3.Cells(45 + increm3, 9) = Feuil6.Cells(1, i + 4) & ", " & Feuil6.Cells(j + 4, 1)
 
            increm3 = increm3 + 1
        End If
 
    Next j
Next i
 
Feuil3.Cells(43, 9) = increm3
 
'       2)b)RECHERCHE D'UNE SORTIE FINALE A TRAITER
 
'           2)b)1)PREMIERE ITERATION (avec placement 1er lien arbitraire : premier de la liste)
 
casderlienvert = Feuil3.Cells(45, 7)
increm5 = 0
 
fluxrestant = 0
fluxtraite = 0
Feuil3.Cells(42, 12) = fluxtraite
 
branche_suivante: 'branche_suivante: coder pour refaire l'opération pour une autre branche
 
increm5 = 0 'compteur pour la construction des liens
 
increm4 = 1
 
 
    Feuil3.Cells(200, 200) = casderlienvert
 
    nbgreenlinks = Feuil3.Cells(43, 7)
 
        'J'ai ValsortieV = SX ou SXX
        If InStr(Feuil3.Cells(200, 200), ",") = 3 And Len(Feuil3.Cells(200, 200)) = 6 Then
            ValsortieV = Mid(Feuil3.Cells(200, 200), 5, 2)
          ElseIf InStr(Feuil3.Cells(200, 200), ",") = 3 And Len(Feuil3.Cells(200, 200)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(200, 200), 5, 3)
          ElseIf InStr(Feuil3.Cells(200, 200), ",") = 4 And Len(Feuil3.Cells(200, 200)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(200, 200), 6, 2)
          ElseIf InStr(Feuil3.Cells(200, 200), ",") = 4 And Len(Feuil3.Cells(200, 200)) = 8 Then
            ValsortieV = Mid(Feuil3.Cells(200, 200), 6, 3) 'Valeur sortie de la 1ère case verte
        End If                                       'récupérée dans ValsortieV
 
 
        'J'ai ValsortieO = SX ou SXX
        For i = 0 To Feuil3.Cells(43, 9) - 1 'Pour toutes les cases orange
 
           If InStr(Feuil3.Cells(45 + i, 9), ",") = 3 Then 'Recherche valeur de sortie orange
              ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 2)
            ElseIf InStr(Feuil3.Cells(45 + i, 9), ",") = 4 Then
              ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 3) 'Valeur sortie de case orange récupérée
           End If                                       'dans ValsortieO
 
           If ValsortieO = ValsortieV Then 'Si sortie correspondante trouvée fait ça :
            Feuil3.Cells(200 + increm4, 200 + increm4) = Feuil3.Cells(45 + i, 9)
            increm4 = increm4 + 1
           End If
        Next i 'Sinon continue de chercher avec la prochaine case
 
                        'ETAT : 1ère case orange rattachée
 
 
'           2)b)2)N IEME ITERATION
 
        'J'ai ValentreeO = EX ou EXX
        If InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 6 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 3)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 8 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 3)
        End If       'Valeur entrée de case orange dans ValentreeO
 
        'J'ai ValentreeV =EX ou EXX
        For i = 0 To Feuil3.Cells(43, 7) - 1 'Pour toutes les cases vertes
            If InStr(Feuil3.Cells(45 + i, 7), ",") = 3 Then 'Recherche valeur d'entrée verte correspondante
                ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 2)
              ElseIf InStr(Feuil3.Cells(45 + i, 7), ",") = 4 Then
                ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 3) 'Valeur entrée de case verte récupérée
            End If                                        'dans ValentreeV
 
            If ValentreeO = ValentreeV Then 'Si entrée correspondante trouvée fait ça :
                Feuil3.Cells(200 + increm4, 200 + increm4) = Feuil3.Cells(45 + i, 7)
                increm4 = increm4 + 1
            End If
        Next
 
 
 
 
reincrement:
 
verifevolincrem4 = increm4 'vérifier que l'incrément increm4 a été incrémenté (plus loin) en le comparant à sa valeur ici
 
        'J'ai ValsortieVi
        If InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 6 Then
            ValsortieV = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 3)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 8 Then
            ValsortieV = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 3) 'Valeur sortie de la 1ère case verte
        End If                                                                 'Valeur entrée de case orange dans ValentreeO
 
        'J'ai ValsortieO = SX ou SXX
        For i = 0 To Feuil3.Cells(43, 9) - 1 'Pour toutes les cases orange
 
           If InStr(Feuil3.Cells(45 + i, 9), ",") = 3 Then 'Recherche valeur de sortie orange
              ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 2)
            ElseIf InStr(Feuil3.Cells(45 + i, 9), ",") = 4 Then
              ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 3) 'Valeur sortie de case orange récupérée
           End If                                       'dans ValsortieO
 
           If ValsortieO = ValsortieV Then 'Si sortie correspondante trouvée fait ça :
            Feuil3.Cells(200 + increm4, 200 + increm4) = Feuil3.Cells(45 + i, 9) 'Noter la sortie suivante
            increm4 = increm4 + 1 'incrémenter pour la prochaine entrée/sortie à renseigner
           End If
        Next i 'Sinon continue de chercher avec la prochaine case
 
 
        'J'ai ValentreeO = EX ou EXX
        If InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 6 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 3)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 8 Then
            ValentreeO = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 3)
        End If       'Valeur entrée de case orange dans ValentreeO
 
        'J'ai ValentreeV =EX ou EXX
        For i = 0 To Feuil3.Cells(43, 7) - 1 'Pour toutes les cases vertes
            If InStr(Feuil3.Cells(45 + i, 7), ",") = 3 Then 'Si virgule en 3ème position, entrée de forme EX
                ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 2) 'Récupérer les 2 premiers caractères dans ValentreeV
              ElseIf InStr(Feuil3.Cells(45 + i, 7), ",") = 4 Then 'Si virgule en 4ème position, entrée de forme EXX
                ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 3) 'Récupérer les 3 premiers caractères dans ValentreeV
            End If
 
            If ValentreeO = ValentreeV Then 'Si entrée correspondante trouvée fait ça :
                Feuil3.Cells(200 + increm4, 200 + increm4) = Feuil3.Cells(45 + i, 7) 'Noter l'entrée suivante
                increm4 = increm4 + 1 'incrémenter pour la prochaine entrée/sortie à renseigner
            End If
        Next
 
 
If verifevolincrem4 <> increm4 Then 'Si les deux valeurs ne sont pas égales, il faut continuer donc repartir pour rechercher la sortie finale
 
GoTo reincrement '
End If
 
 
            'Récupérer le nom de la dernière sortie --> Dersortie
        If InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 6 Then
            Dersortie = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 3 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            Dersortie = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 5, 3)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 7 Then
            Dersortie = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 2)
          ElseIf InStr(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), ",") = 4 And Len(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)) = 8 Then
            Dersortie = Mid(Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1), 6, 3)
        End If
 
        'Récupérer le nom du dernier lien --> derlien
        derlien = Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)
        Range(Feuil3.Cells(200, 200), Feuil3.Cells(200 + increm4 - 1, 200 + increm4 - 1)).ClearContents
 
'       2)c)RÉCUPÉRATION DE L'ORDRE et STOCKAGE DANS LES NIVEAUX D'UN TABLEAU
 
'            2)c)1)EDITION NIVEAU PAR NIVEAU EN PARTANT DE LA SORTIE FINALE TROUVÉE
 
Dim incremX As Integer
Dim incremY As Integer
Dim nbidentik As Integer
    incremX = 0
    incremY = 0
    nbidentik = 0
    Feuil3.Cells(2000 + incremY, 2000 + incremX) = Dersortie 'NIVEAU N = 0 'initialisation
    ValsortieO = Dersortie
    Feuil3.Cells(1999, 2000) = 1
 
reprendre_ici:     'départ de la boucle stockant entrées et sorties en fonction de leur place dans le tableau
 
 
incremX = incremX + 1    'ne différencie que par rapport à la dernière valeur
incremY = 0
 
For j = 1 To Feuil3.Cells(1999, 2000 + incremX - 1) 'Pour le nombre de sorties précédents stockées dans le tableau
 
  ValsortieO = Feuil3.Cells(2000 + j - 1, 2000 + incremX - 1)
 
    For i = 0 To Feuil3.Cells(43, 7) - 1   'Pour le nombre de liens verts
 
        If InStr(Feuil3.Cells(45 + i, 7), ",") = 3 And Len(Feuil3.Cells(45 + i, 7)) = 6 Then  'Stockage de entrées et sorties vertes
            ValsortieV = Mid(Feuil3.Cells(45 + i, 7), 5, 2)
            ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 2)
          ElseIf InStr(Feuil3.Cells(45 + i, 7), ",") = 3 And Len(Feuil3.Cells(45 + i, 7)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(45 + i, 7), 5, 3)
            ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 2)
          ElseIf InStr(Feuil3.Cells(45 + i, 7), ",") = 4 And Len(Feuil3.Cells(45 + i, 7)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(45 + i, 7), 6, 2)
            ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 3)
          ElseIf InStr(Feuil3.Cells(45 + i, 7), ",") = 4 And Len(Feuil3.Cells(45 + i, 7)) = 8 Then
            ValsortieV = Mid(Feuil3.Cells(45 + i, 7), 6, 3)
            ValentreeV = Mid(Feuil3.Cells(45 + i, 7), 1, 3)
        End If
 
        If ValsortieV = ValsortieO Then       'Si la fin correspond à "ValsortieO"
            Feuil3.Cells(2000 + incremY, 2000 + incremX) = ValentreeV     'Récupération des entrées + collage dans le tableau     (E33) (E29)
            incremY = incremY + 1    'Passage à la ligne suivante
            Range(Feuil3.Cells(2000, 2000 + incremX), Feuil3.Cells(2000 + incremY, 2000 + incremX)).RemoveDuplicates Columns:=1, Header:=xlNo 'supression des doublons
                For n = 0 To incremY 'changement de incremY en fonction du nb de cases actuellement
                    If IsEmpty(Feuil3.Cells(2000 + n, 2000 + incremX)) = False Then
                        compteurapdoublon = compteurapdoublon + 1
                    End If
 
                Next n
 
                incremY = compteurapdoublon
 
            Feuil3.Cells(1999, 2000 + incremX) = incremY
            compteurapdoublon = 0
 
        End If
 
    Next i
 
Next j
 
'           2)c)2)RECHERCHE DE COLONNE IDENTIQUE POUR PASSAGE BRANCHE SUIVANTE
 
 
For k = 0 To incremX - 1 'Pour le nb de lignes
    For m = 0 To incremY 'Pour le nombre de colonnes dans le tableau
        If Feuil3.Cells(2000 + m, 2000 + k) = Feuil3.Cells(2000 + m, 2000 + incremX) And IsEmpty(Feuil3.Cells(2000 + m, 2000 + k)) = False Then
        nbidentik = nbidentik + 1 'Si la cellule est identique alors on incrémente le compteur
        End If
    Next m 'ligne suivante
    If nbidentik = incremY And nbidentik <> 0 Then 'Si les deux colonnes identiques
        Range(Feuil3.Cells(1999, 2000 + incremX), Feuil3.Cells(2000 + incremY, 2000 + incremX)).ClearContents 'Supprimer la colonne en doublon
        Exit For
    End If
 
nbidentik = 0
 
Next k
 
 
'           2)c)3)DEBUT DU CAS RECHERCHE DES SORTIES SUIVANTES
 
incremY = 0
incremX = incremX + 1
 
For j = 1 To Feuil3.Cells(1999, 2000 + incremX - 1) 'Pour le nombre d'entrées précédents stockées dans le tableau
 
   ValentreeV = Feuil3.Cells(2000 + j - 1, 2000 + incremX - 1)
 
    For i = 0 To Feuil3.Cells(43, 9) - 1   'Pour le nombre de liens oranges
 
    If InStr(Feuil3.Cells(45 + i, 9), ",") = 3 And Len(Feuil3.Cells(45 + i, 9)) = 6 Then  'Stockage des entrées et sorties oranges
        ValentreeO = Mid(Feuil3.Cells(45 + i, 9), 5, 2)
        ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 2)
      ElseIf InStr(Feuil3.Cells(45 + i, 9), ",") = 3 And Len(Feuil3.Cells(45 + i, 9)) = 7 Then
        ValentreeO = Mid(Feuil3.Cells(45 + i, 9), 5, 3)
        ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 2)
      ElseIf InStr(Feuil3.Cells(45 + i, 9), ",") = 4 And Len(Feuil3.Cells(45 + i, 9)) = 7 Then
        ValentreeO = Mid(Feuil3.Cells(45 + i, 9), 6, 2)
        ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 3)
      ElseIf InStr(Feuil3.Cells(45 + i, 9), ",") = 4 And Len(Feuil3.Cells(45 + i, 9)) = 8 Then
        ValentreeO = Mid(Feuil3.Cells(45 + i, 9), 6, 3)
        ValsortieO = Mid(Feuil3.Cells(45 + i, 9), 1, 3)
    End If
 
    If ValentreeO = ValentreeV Then     'Si la fin correspond à "ValentreeV"
        Feuil3.Cells(2000 + incremY, 2000 + incremX) = ValsortieO     'Récupération des sorties + collage dans le tableau   (S23)
        incremY = incremY + 1    'écrire la prochaine sortie sur la ligne suivante
        Range(Feuil3.Cells(2000, 2000 + incremX), Feuil3.Cells(2000 + incremY, 2000 + incremX)).RemoveDuplicates Columns:=1, Header:=xlNo 'Suppression des doublons
        For n = 0 To incremY 'changement de incremY en fonction du nb de cases actuellement
 
            If IsEmpty(Feuil3.Cells(2000 + n, 2000 + incremX)) = False Then
                compteurapdoublon = compteurapdoublon + 1
            End If
 
        Next n
 
                incremY = compteurapdoublon
 
        Feuil3.Cells(1999, 2000 + incremX) = incremY
        compteurapdoublon = 0
 
        End If
 
    Next i
 
Next j
 
'           2)c)4)RECHERCHE DE COLONNE IDENTIQUE POUR PASSAGE BRANCHE SUIVANTE
 
For k = 0 To incremX - 1 'Pour le nb de lignes
    For m = 0 To incremY 'Pour le nombre de colonnes dans le tableau
        If Feuil3.Cells(2000 + m, 2000 + k) = Feuil3.Cells(2000 + m, 2000 + incremX) And IsEmpty(Feuil3.Cells(2000 + m, 2000 + k)) = False Then
        nbidentik = nbidentik + 1 'Si la cellule est identique alors on incrémente le compteur
        End If
    Next m
    If nbidentik = incremY And nbidentik <> 0 Then 'Si les deux colonnes identiques
        Range(Feuil3.Cells(1999, 2000 + incremX), Feuil3.Cells(2000 + incremY, 2000 + incremX)).ClearContents 'Supprimer la colonne en doublon
        Exit For   'Normalement il faudra écrire
    End If
Next k
 
If incremY <> 0 Then 'Tant qu'il y a des résultats, incremY est différent de 0 alors
GoTo reprendre_ici 'On continue la recherche
End If
 
 
'       2)d)MISE EN FORME DE L'ORDRE DES ENTREES SORTIES A TRAITER
 
'           2)d)1)RECHERCHE ET COLLAGE DES ENTRÉES SORTIES DU TABLEAU DANS LISTE
 
hauteurtable = Application.WorksheetFunction.Max(Range(Feuil3.Cells(1999, 2000), Feuil3.Cells(1999, 2000 + incremX))) 'le maximum du décompte donne la hauteur du tableau à traiter
largeurtable = incremX + 1 'la largeur du tableau correspond à la valeur de l'incrément en X plus 1
 
For i = 0 To largeurtable - 1 'Pour le nb de colonnes
 
    For j = 0 To hauteurtable - 1 'Pour le nb de lignes
 
        If IsEmpty(Feuil3.Cells(2000 + j, 2000 + i)) = False Then 'Si la cellule n'est pas vide alors
            Feuil3.Cells(44 + increm5 + fluxtraite, 12) = Feuil3.Cells(2000 + j, 2000 + i) 'On la stocke sur colonne à côté
            increm5 = increm5 + 1 'Ligne suivante pour la partie stockage
        End If
 
    Next j 'Ligne suivante pour recherche
 
Next i 'colonne suivante pour recherche
 
For n = 0 To increm5 'changement de incremY en fonction du nb de cases actuellement
 
            If IsEmpty(Feuil3.Cells(44 + n, 12)) = False Then
                fluxtraite = fluxtraite + 1
                Feuil3.Cells(42, 12) = fluxtraite
            End If
 
Next n
 
Range(Feuil3.Cells(1999, 2000), Feuil3.Cells(2000 + hauteurtable, 2000 + largeurtable)).ClearContents 'Supprimer le tableau traitement
'Supprmier le tableau qui a servi à faire la lsite pour laisser la place au prochain
 
For i = 1 To compteuren + compteurso
    Feuil3.Cells(43 + i, 14) = Feuil1.Cells(2 + i, 2)
'Coller sur la feuille la liste des entrées et des sorties du système
Next i
 
 
pasfini:
 
For i = 1 To compteuren + compteurso
    For j = 1 To fluxtraite
        If Feuil3.Cells(43 + j, 12) = Feuil3.Cells(43 + i, 14) And IsEmpty(Feuil3.Cells(43 + i, 14)) = False Then
            Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule du flux déjà utilisé
            GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
 
' // ATTENTION !!! \\ à retirer car premet de supprimer les liens qui ont mal été traités en amont !!!
 
          ElseIf Feuil3.Cells(43 + i, 14) = "S6" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "S11" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "S12" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "S14" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "S15" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "E10" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "E11" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "E13" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "E16" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
          ElseIf Feuil3.Cells(43 + i, 14) = "E17" Then
           Feuil3.Cells(43 + i, 14).Delete Shift:=xlUp 'Supprimer la cellule de lien vert car non traitée
           GoTo pasfini 'Retour au début de la partie "FILTRE DES LIENS DEJA TRAITES pour traiter la cellule qui va prendre ses coordonnées
 
' // ATTENTION !!! \\ à retirer car premet de supprimer les liens qui ont mal été traités en amont !!!
 
        End If
    Next j
Next i
 
 
For i = 1 To nbgreenlinks
 
        If InStr(Feuil3.Cells(44 + i, 7), ",") = 3 And Len(Feuil3.Cells(44 + i, 7)) = 6 Then  'Stockage de entrées et sorties vertes
            ValsortieV = Mid(Feuil3.Cells(44 + i, 7), 5, 2)
            ValentreeV = Mid(Feuil3.Cells(44 + i, 7), 1, 2)
          ElseIf InStr(Feuil3.Cells(44 + i, 7), ",") = 3 And Len(Feuil3.Cells(44 + i, 7)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(44 + i, 7), 5, 3)
            ValentreeV = Mid(Feuil3.Cells(44 + i, 7), 1, 2)
          ElseIf InStr(Feuil3.Cells(44 + i, 7), ",") = 4 And Len(Feuil3.Cells(44 + i, 7)) = 7 Then
            ValsortieV = Mid(Feuil3.Cells(44 + i, 7), 6, 2)
            ValentreeV = Mid(Feuil3.Cells(44 + i, 7), 1, 3)
          ElseIf InStr(Feuil3.Cells(44 + i, 7), ",") = 4 And Len(Feuil3.Cells(44 + i, 7)) = 8 Then
            ValsortieV = Mid(Feuil3.Cells(44 + i, 7), 6, 3)
            ValentreeV = Mid(Feuil3.Cells(44 + i, 7), 1, 3)
        End If
 
        If ValsortieV = Feuil3.Cells(44, 14) Then
            casderlienvert = Feuil3.Cells(44 + i, 7)
        End If
 
Next i
 
'Compteur fluxrestant
For i = 1 To Cells(43, 7)
    If IsEmpty(Cells(43 + i, 14)) = False Then
        fluxrestant = fluxrestant + 1
        Feuil3.Cells(42, 14) = fluxrestant
    End If
Next
 
 
 
If IsEmpty(Cells(44, 14)) = False Then
    For i = 1 To compteuren + compteurso
        Feuil3.Cells(43 + i + fluxrestant, 14) = Feuil1.Cells(2 + i, 2)
    'Coller sur la feuille la liste des entrées et des sorties du système
    Next i
    GoTo branche_suivante
End If
 
 
 
 
 
'Suppression des cases vides
For i = 1 To Cells(42, 12)
    If IsEmpty(Cells(43 + i, 12)) = True Then
        Feuil3.Cells(43 + i, 12).Delete Shift:=xlUp
    End If
Next
 
'Compteur fluxtraitefinal
For i = 1 To Cells(42, 12)
    If IsEmpty(Cells(43 + i, 12)) = False Then
        fluxrestantfinal = fluxrestantfinal + 1
        Feuil3.Cells(40, 12) = fluxrestantfinal
    End If
Next

Élaboration automatique d'un jeu de domino à partir des pièces uniques [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager