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
|
Option Explicit
'Option Private Module
'utilisé par Double_Seuil
Enum SEUIL
Minimum = 0
Maximum = 1
End Enum
'Contraindre: Largeur True/limites.
Enum CONTRAINDRE
AUCUNE = 0
Hauteur = 1
Largeur = 2
End Enum
'associé au Type Tri et Limites
Enum ORIENTATION_TRI
Horizontal = 0
Vertical = 1
End Enum
'associé au Type Tri
Enum ORDRE_TRI
Croissant = 0
Decroissant = 1
End Enum
'type utilisé pour stocker des valeurs et indices mimimal et maximal du tableau
Type Min_Max
mini As Variant
maxi As Variant
Ligne_Mini As Long
Colonne_Mini As Long
Ligne_Maxi As Long
Colonne_Maxi As Long
End Type
'type contenant les argument utilisé par la fonction Trier
Type Tri
Table_Data() As Variant
Keys As Variant
Sans_Etiquette As Boolean
ignorer_Blank As Boolean
Limitation As CONTRAINDRE
Grandeur As ORDRE_TRI
Orientation As ORIENTATION_TRI
Valeurs1 As Min_Max
Valeurs2 As Min_Max
End Type
Function CLASSER(ByVal Liste As Variant, _
Optional ByVal Keys As Variant = -1, _
Optional ByVal Ordre As ORDRE_TRI = 1, _
Optional ByVal En_tete As Boolean = True, _
Optional ByVal Direction As ORIENTATION_TRI = 0, _
Optional ByVal Ignorer_vide As Boolean) As Variant
Dim Reperes As Min_Max, Decalages As Min_Max
Dim Contrainte As CONTRAINDRE
Dim rapport As Variant, cours As Variant, Tab_Tri() As Variant, v
Dim keyCompte() As Long, nb_Col As Long, nbKey As Long, Avec_col As Long, _
fin As Long, debut As Long, i As Integer, n As Integer
'les erreurs provoqués par des arguments invalides ne seront pas géré
'Bloc Config Paramètres
Application.Volatile False
With Application
.Interactive = False
.EnableCancelKey = xlInterrupt
.CalculationInterruptKey = xlEscKey
' .ScreenUpdating = False
' .Calculation = xlCalculationManual
End With
v = Liste ' copier la valeur du paramètre
If Not IsArray(v) Then Exit Function
Liste = Empty
Tab_Tri = v
v = Empty
ReDim keyCompte(0) 'conformiser un tableau pour les clés
If IsArray(Keys) Then
nbKey = -1
For i = LBound(Keys) To UBound(Keys)
nbKey = nbKey + 1
ReDim Preserve keyCompte(0 To nbKey)
keyCompte(nbKey) = Keys(i)
Next
Else
ReDim keyCompte(0)
keyCompte(0) = Keys
End If
nb_Col = nb_Col - 1
On Error Resume Next
nb_Col = UBound(Tab_Tri, 2) ' test multi-colonnes
If Err Then Err.Clear
On Error GoTo 0
'décalage négatif d'un pas sur la liste avec le compteur keyCompte
'keyCompte incrementé, renverra dans la boucle qui suit, le key précédent
Avec_col = -1
For i = 0 To UBound(keyCompte)
If i > LBound(keyCompte) Then _
Avec_col = keyCompte(i - 1) 'la clé précédente ainsi stockée sert de paramètre de groupage
'initialise
With Decalages
.Colonne_Maxi = -1
.Colonne_Mini = -1
.Ligne_Maxi = -1
.Ligne_Mini = -1
End With
' obtenir les valeurs de base par la fonction Valider_Indices qui permet
'de conformiser les variables d'incrémentation en testant la clé. Renvoi True si correct
If Valider_Indices(Tab_Tri, Contrainte, Decalages, keyCompte(i), nb_Col) = False Then Exit Function
'calages d'indices
With Decalages
If Direction = 1 Then 'Contrôle d'orientation du tri, si par colonnes ou lignes
.Ligne_Mini = keyCompte(i) 'indice verrouillé
.Ligne_Maxi = keyCompte(i)
If En_tete Then .Colonne_Mini = .Colonne_Mini + 1
fin = .Colonne_Maxi
debut = .Colonne_Mini
Reperes = Decalages 'stockage initial avant modifi...
.Colonne_Mini = .Colonne_Mini - 1
.Colonne_Maxi = .Colonne_Maxi + 1
Contrainte = 1 'Hauteur
Else 'le sens du tri est par lignes
.Colonne_Maxi = keyCompte(i) 'indice verrouillé
.Colonne_Mini = keyCompte(i) 'indice verrouillé
Contrainte = 2 'Largeur
If En_tete Then .Ligne_Mini = .Ligne_Mini + 1
Reperes = Decalages 'copier décalages dans repères avant son initialisation
fin = .Ligne_Maxi
debut = .Ligne_Mini
.Ligne_Mini = .Ligne_Mini - 1
.Ligne_Maxi = .Ligne_Maxi + 1
End If
End With
If Avec_col <> -1 And Avec_col <> keyCompte(i) Then
Do
n = debut - 1
Do 'déterminer la limite d'un groupe de données semblables
n = n + 1
If Direction = 1 Then
If n = fin Then n = n + 1
cours = Tab_Tri(Avec_col, n)
Reperes.Colonne_Maxi = n - 1
Reperes.Colonne_Mini = debut
Decalages.Colonne_Maxi = n
Decalages.Colonne_Mini = debut - 1
rapport = Tab_Tri(Avec_col, debut)
Else
cours = Tab_Tri(n, Avec_col)
Reperes.Ligne_Maxi = n - 1
Reperes.Ligne_Mini = debut
'If n = fin Then n = n + 1
Decalages.Ligne_Maxi = n
Decalages.Ligne_Mini = debut - 1
rapport = Tab_Tri(debut, Avec_col)
End If
Loop Until cours <> rapport Or n >= fin
'boucler sur les limites obtenues
GoSub Trafic
debut = n
Loop Until n >= fin
Else
GoSub Trafic
End If
Next
CLASSER = Tab_Tri
With Application
.Interactive = True
'.EnableCancelKey = xlInterrupt
'.CalculationInterruptKey = xlEscKey
.ScreenUpdating = True
'.Calculation = xlCalculationManual
End With
Application.Volatile False
Exit Function
Trafic:
'boucle effectuée sur une plage d'indices contenues dans le tableau, pour ordonner les éléments
Do
'reperages des indices de tableau contenant les valeurs minimal et maximal par la fonction Double_Seuil
If Double_Seuil(Tab_Tri, Reperes, Contrainte, keyCompte(i), nb_Col, Ordre) = "" Then Exit Do
'reorganisation des données par la fonction Decaleur
Loop Until Decaleur(Tab_Tri, Direction, Avec_col, nb_Col, Ordre, Reperes, Decalages) = False
Return
End Function
Private Function Decaleur(ByRef Liste, Direction As ORIENTATION_TRI, last_Key As Long, Multi_col As Long, Ordre As ORDRE_TRI, _
Reperes As Min_Max, Decalages As Min_Max)
Dim i As Long, l As Long, c As Long, cur_Key As Long, groupe, id1 As Long, id2 As Long
'les indices repères obtenues par la fonction Double_Seuil, permettent d'effectuer le déplacement
'les indices repères sont ensuite initialisé sur ceux du décalages ici.
'Contrôle d'orientation du tri, si par colonnes ou lignes
With Decalages
If Direction = 1 Then 'vertical
.Colonne_Mini = .Colonne_Mini + 1
.Colonne_Maxi = .Colonne_Maxi - 1
If .Colonne_Maxi <= .Colonne_Mini Then _
Decaleur = False: _
Exit Function
id1 = Reperes.Colonne_Maxi: id2 = Reperes.Colonne_Mini
If Ordre = 0 Then _
id1 = Reperes.Colonne_Mini: id2 = Reperes.Colonne_Maxi 'inversion
Reperes.Colonne_Mini = .Colonne_Mini + 1
Reperes.Colonne_Maxi = .Colonne_Maxi - 1
Else
.Ligne_Mini = .Ligne_Mini + 1
.Ligne_Maxi = .Ligne_Maxi - 1
If .Ligne_Maxi <= .Ligne_Mini Then _
Decaleur = False: _
Exit Function
id1 = Reperes.Ligne_Maxi: id2 = Reperes.Ligne_Mini
If Ordre = 0 Then _
id1 = Reperes.Ligne_Mini: id2 = Reperes.Ligne_Maxi 'inversion
Reperes.Ligne_Mini = .Ligne_Mini + 1
Reperes.Ligne_Maxi = .Ligne_Maxi - 1
End If
End With
If Multi_col > -1 Then
For i = LBound(Liste, 2 - Direction) To UBound(Liste, 2 - Direction)
If i <> last_Key Then
'déplacement des valeurs en fonction de l'argument direction
If Direction = 1 Then
Decalages.mini = Liste(i, id1)
Decalages.maxi = Liste(i, id2)
Liste(i, id1) = Liste(i, Decalages.Colonne_Mini)
Liste(i, id2) = Liste(i, Decalages.Colonne_Maxi)
Liste(i, Decalages.Colonne_Mini) = Decalages.mini
Liste(i, Decalages.Colonne_Maxi) = Decalages.maxi
Else
Decalages.mini = Liste(id1, i)
Decalages.maxi = Liste(id2, i)
Liste(id1, i) = Liste(Decalages.Ligne_Mini, i)
Liste(id2, i) = Liste(Decalages.Ligne_Maxi, i)
Liste(Decalages.Ligne_Mini, i) = Decalages.mini
Liste(Decalages.Ligne_Maxi, i) = Decalages.maxi
End If
End If
Next
Else
'une dimension donc
Decalages.mini = Liste(id1)
Decalages.maxi = Liste(id2)
Liste(id1) = Liste(Decalages.Ligne_Mini)
Liste(id2) = Liste(Decalages.Ligne_Maxi)
Liste(Decalages.Ligne_Mini) = Decalages.mini
Liste(Decalages.Ligne_Maxi) = Decalages.maxi
Reperes.mini = ""
Reperes.maxi = ""
End If
Decaleur = True
End Function
Private Function Double_Seuil(ByRef Liste() As Variant, _
ByRef Seuils As Min_Max, _
Optional Contrainte As CONTRAINDRE, _
Optional Cle As Long, _
Optional nb_Col As Long = -1, _
Optional Limite As SEUIL) As Variant
Dim n As Long, MinMax
'permet d'obtenir une des deux valeurs extrêmes en fonction de l'argument "Seuil"
'si l'argument "Seuil" n'est pas fourni, renvoi un tableau de 2 éléments contenant les 2 extrêmes. _
'La methode s'appui sur un jeu subdivisé en sous private fonction.
Double_Seuil = ""
If Valider_Indices(Liste, Contrainte, Seuils, Cle, nb_Col) Then
If Contrainte <> 0 Then
MinMax = Avec_Contrainte(Liste, Cle, Seuils, Contrainte, nb_Col)
Else
MinMax = Sans_Contrainte(Liste, Seuils, nb_Col)
End If
If Limite < 2 Then
Double_Seuil = MinMax(Limite)
Else
Double_Seuil = MinMax
End If
End If
End Function
Function Valider_Indices(ByRef Liste(), Contrainte As CONTRAINDRE, _
Indices As Min_Max, Cle As Long, Optional nb_Col As Long = -1)
'Validation: renvoi True si les paramètres sont corrects.
' teste et déterminer la validité des arguments optionnels en changeant éventuellement leurs valeurs.
'la fonction a pour rôle d'initialiser les valeurs de ses arguments
'Dim MinMax(1 To 2, 1 To 2), elem, n As Integer, v(2) As Boolean ', f As Long
Valider_Indices = False
If Cle = -1 Then
If nb_Col <> -1 Then
Cle = LBound(Liste, 2)
Else
Cle = LBound(Liste)
End If
End If
If Indicer(Liste, Indices, nb_Col) Then ' définition
If Valider(Liste, Indices, nb_Col) Then 'validation contraintes indices
If Stat_Key(Cle, Contrainte, Liste, nb_Col) Then 'validation clé
If nb_Col <> -1 Then
Indices.mini = Liste(Indices.Ligne_Mini, Indices.Colonne_Mini)
Indices.maxi = Liste(Indices.Ligne_Maxi, Indices.Colonne_Maxi)
Else
Indices.mini = Liste(Indices.Ligne_Mini)
Indices.maxi = Liste(Indices.Ligne_Maxi)
End If
Valider_Indices = True
End If
End If
End If
End Function
Private Function Indicer(Liste, TabIndices As Min_Max, Optional nb_Col As Long = -1)
'Fonction éxécutant une séquence de tests définissant les indices
'Renvoi true ou false. peut affecter les valeurs de l'argument TabIndices
Indicer = False 'init
With TabIndices
.Ligne_Mini = Switch(.Ligne_Mini = -1, LBound(Liste), _
.Ligne_Mini > -1, .Ligne_Mini)
.Ligne_Maxi = Switch(.Ligne_Maxi = -1, UBound(Liste), _
.Ligne_Maxi > -1, .Ligne_Maxi)
If nb_Col <> -1 Then
.Colonne_Mini = Switch(.Colonne_Mini = -1, LBound(Liste, 2), _
.Colonne_Mini > -1, .Colonne_Mini)
.Colonne_Maxi = Switch(.Colonne_Maxi = -1, UBound(Liste, 2), _
.Colonne_Maxi > -1, .Colonne_Maxi)
End If
End With
Indicer = True
End Function
Private Function Valider(Liste, Reperes As Min_Max, Optional nb_Col As Long = -1)
Dim d, f
'test les indices. renvoi true ou false si correct.
'n'affectte pas ses arguments
With Reperes
d = Switch(.Ligne_Mini > UBound(Liste), .Ligne_Maxi, _
(.Ligne_Mini <> -1) = (.Ligne_Mini < LBound(Liste)), .Ligne_Mini, _
.Ligne_Mini > .Ligne_Maxi, .Ligne_Mini, _
.Ligne_Maxi > UBound(Liste), .Ligne_Maxi, _
(.Ligne_Maxi <> -1) = (.Ligne_Maxi < LBound(Liste)), .Ligne_Maxi, _
.Ligne_Maxi < .Ligne_Mini, .Ligne_Maxi)
If nb_Col <> -1 Then
f = Switch(.Colonne_Mini > UBound(Liste, 2), .Colonne_Mini, _
(.Colonne_Mini <> -1) = (.Colonne_Mini < LBound(Liste, 2)), .Colonne_Mini, _
.Colonne_Mini > .Colonne_Maxi, .Colonne_Mini, _
.Colonne_Maxi > UBound(Liste, 2), .Colonne_Maxi, _
(.Colonne_Maxi <> -1) = (.Colonne_Maxi < LBound(Liste)), .Colonne_Maxi, _
(.Colonne_Maxi <> -1) = (.Colonne_Maxi < .Colonne_Mini), .Colonne_Maxi)
End If
End With
If d Or f Then
Valider = False
Else
Valider = True
End If
End Function
Private Function Stat_Key(Cle As Long, Direction As ORIENTATION_TRI, Liste(), Optional nb_Col As Long = -1)
Dim v1 As Boolean, v2 As Boolean
' permet de vérifier si la clé est dans les limites
If nb_Col <> -1 Then
If Direction = 1 Then
Stat_Key = Cle >= LBound(Liste, 2) And Cle <= UBound(Liste, 2)
Else
Stat_Key = Cle >= LBound(Liste, 1) And Cle <= UBound(Liste, 1)
End If
'
Else
Stat_Key = Cle >= LBound(Liste) And Cle <= UBound(Liste)
End If
End Function
Private Function Avec_Contrainte(ByRef Liste As Variant, _
ByRef Cle As Long, _
ByRef ContrainteVAl As Min_Max, _
ByRef ContrainteState As CONTRAINDRE, _
Optional multiColonne As Long = -1) As Variant
Dim l As Long, c As Long
'Avec_Contrainte boucle le tableau en fonction de la plage d'indices fourni dans l'argument ContrainteVAl pour réperer les indices des 2 extrêmes
If multiColonne <> -1 Then
If ContrainteState = 1 Then
l = ContrainteVAl.Colonne_Maxi
For c = ContrainteVAl.Colonne_Mini To l '
'stocker le mini et les indice correspondant
If Liste(Cle, c) < ContrainteVAl.mini Then _
ContrainteVAl.Colonne_Mini = c: _
ContrainteVAl.mini = Liste(Cle, c)
'stocker le maxi et les indice correspondant
If Liste(Cle, c) > ContrainteVAl.maxi Then _
ContrainteVAl.Colonne_Maxi = c: _
ContrainteVAl.maxi = Liste(Cle, c)
Next
Else
c = ContrainteVAl.Ligne_Maxi
For l = ContrainteVAl.Ligne_Mini To c
'stocker le mini et les indice correspondant
If Liste(l, Cle) < ContrainteVAl.mini Then _
ContrainteVAl.Ligne_Mini = l: _
ContrainteVAl.mini = Liste(l, Cle)
'stocker le maxi et les indice correspondant
If Liste(l, Cle) > ContrainteVAl.maxi Then _
ContrainteVAl.Ligne_Maxi = l: _
ContrainteVAl.maxi = Liste(l, Cle)
Next
End If
Else
For l = ContrainteVAl.Ligne_Mini To ContrainteVAl.Ligne_Maxi
'stocker le mini et les indices correspondants
If Liste(l) < ContrainteVAl.mini Then _
ContrainteVAl.Ligne_Mini = l: _
ContrainteVAl.mini = Liste(l)
'stocker le maxi et les indice correspondant
If Liste(l) > ContrainteVAl.maxi Then _
ContrainteVAl.Ligne_Maxi = l: _
ContrainteVAl.maxi = Liste(l)
Next
End If
Avec_Contrainte = Array(ContrainteVAl.mini, ContrainteVAl.maxi)
End Function
Private Function Sans_Contrainte(ByRef Liste As Variant _
, ByRef ContrainteVAl As Min_Max, _
Optional ByVal multiColonne As Long = -1) As Variant
'la fonction boucle tout le tableau pour réperer les indices des 2 extrêmes
Dim l As Long, c As Long
If multiColonne <> -1 Then 'le tableau est bidimensionnel
For l = LBound(Liste, 1) To UBound(Liste, 1)
For c = LBound(Liste, 2) To UBound(Liste, 2)
'stocker le mini et les indice correspondant
If Liste(l, c) < ContrainteVAl.mini Then _
ContrainteVAl.Ligne_Mini = l: _
ContrainteVAl.Colonne_Mini = c: _
ContrainteVAl.mini = Liste(l, c)
'stocker le maxi et les indice correspondant
If Liste(l, c) > ContrainteVAl.maxi Then _
ContrainteVAl.Ligne_Maxi = l: _
ContrainteVAl.Colonne_Maxi = c: _
ContrainteVAl.maxi = Liste(l, c)
Next
Next
Else 'le tableau n'est pas bidimensionnel
For l = LBound(Liste, 1) To UBound(Liste, 1)
'stocker le mini et les indice correspondant
If Liste(l) < ContrainteVAl.mini Then _
ContrainteVAl.Ligne_Mini = l: _
ContrainteVAl.mini = Liste(l)
'stocker le maxi et les indice correspondant
If Liste(l) > ContrainteVAl.maxi Then _
ContrainteVAl.Ligne_Maxi = l: _
ContrainteVAl.maxi = Liste(l)
Next
End If
Sans_Contrainte = Array(ContrainteVAl.mini, ContrainteVAl.maxi)
End Function |
Consulter le profil
Marquer ce blog comme lu
