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
|
Option Explicit
Sub test()
Dim TabDonnées() As Variant
Dim i As Long
' Lecture des données qui sont dans la colonne A
i = 0
While Cells(i + 1, "A") <> ""
ReDim Preserve TabDonnées(i) ' Dimensionne le tableau TabDonnées().
TabDonnées(i) = Cells(i + 1, "A") ' Mémorise la donnée.
i = i + 1 ' ligne suivante.
Wend
Call QuickRanking(TabDonnées, True, 4) ' Renseigne TabDonnées sans les doublons.
For i = 0 To UBound(TabDonnées) ' Boucle sur les éléments de TabDonnées
Cells(i + 1, "B") = TabDonnées(i) ' et les affiche en colonne B.
Next i
End Sub
'----------------------------------------------------------------------------------------
Public Function QuickRanking(ByRef TabDonnées() As Variant, _
Optional ByVal OrdreCroissant As Boolean = True, _
Optional ByVal ModeClassement As Byte = 1, _
Optional ByRef NiveauTest As Long = 15, _
Optional ByRef TauxTest As Long = 0) As Variant
'----------------------------------------------------------------------------------------
' TabDonnées : Tri les données passées en argument et modifie TabDonnées.
' OrdreCroissant : Si vaut True alors ordre croissant, sinon ordre décroissant.
' ModeClassement : 0 = Tri, Pas de classement.
' 1 = Tri + Classement des données, les données égales ont le même ordre.
' 2 = Tri + Classement des données, l'ordre des données égales
' respecte l'ordre d'origine.
' 3 = Uniquement Classement des données, et sans gestion des égalités.
' 4 = Tri sans doublon, et sans Classement.
' NiveauTest : False (0) = Pas de test complémentaire,
' True (-1) = Contrôle les égalités et les suites.
' >0 et <100 = Lance le test pour savoir s'il faut activer ou non l'option,
' où NiveauTest représente le taux de conformité (de 1 à 100)
' pour que l'activation de l'option soit considérée utile.
' NiveauTest sera alimenté du resultat obtenu (Vrai ou Faux).
' TauxTest : Contiendra le taux (0 à 100) des tests efficaces. Utilisé pour tester l'option.
'----------------------------------------------------------------------------------------
' S'il faut lancer le test du choix de l'option pour NiveauTest. NiveauTest contient
' le pourcentage de réussité désiré des tests complémentaires pour activer l'option:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If NiveauTest > 0 Then NiveauTest = TesterNiveauQR(TabDonnées(), NiveauTest)
' Bornes du tableau des données d'origine:
Dim TabDébut As Long, TabFin As Long
On Error Resume Next ' Si aucune donnée à trier.
TabDébut = LBound(TabDonnées)
TabFin = UBound(TabDonnées)
' Controle que TabDonnées est de la forme TabDonnées(0 To i):
If TabDébut <> 0 Then
MsgBox "Erreur de programmation: TabDonnées doit être de la forme TabDonnées(0 To i)", _
vbCritical + vbOKOnly, "QuickRanking"
Exit Function
End If
' Gestion des erreurs:
Err.Clear
On Error GoTo Gest_Err
' Initialisation du tableau du classement des données:
ReDim ref(TabDébut - 2 To TabFin) As Long
' Si rien à trier alors quitte:
If Abs(TabFin - TabDébut) < 1 Then QuickRanking = ref(): Exit Function
' Initialisation des variables pour le traitement de tri:
Dim Tps As Variant, ValMini As Variant, ValMaxi As Variant
Dim i As Long, n As Long, j As Long, Anc As Long, l As Long
Dim RefMini As Long, RefMaxi As Long, MaxiRac As Long, MiniRac As Long
Dim NbPassage As Long, Début As Long, Fin As Long
Dim NbRechercheDicho As Long, MaxiDoWhile As Long, Compteur As Long
' Initialisation du tableau des données déjà classées:
ReDim TabTps(TabDébut - 2 To TabFin) As Long
MaxiRac = TabDébut
NbPassage = TabFin
' Configure le classement des 2 premiers éléments:
If TabDonnées(TabDébut) > TabDonnées(TabDébut + 1) Then n = 1
RefMini = TabDébut + n
RefMaxi = TabDébut + 1 - n
ref(TabDébut) = TabDébut + 1
ref(TabDébut + 1) = RefMaxi
ValMini = TabDonnées(RefMini)
ValMaxi = TabDonnées(RefMaxi)
' Si l'option des tests complémentaires est à Vrai (-1):
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If NiveauTest = True Then
' Boucle sur les éléments à classer en effectuant les tests complémentaires:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For n = 2 + TabDébut To TabFin
Tps = TabDonnées(n)
' Controle le débordement du mini:
Do Until Tps > ValMini ' Plus rapide que If Tps <= ValMini Then... End If.
ref(n) = RefMini ' La données suivante de n est l'ancien minimum.
RefMini = n ' Mémorise qui est le nouveau minimum.
TabTps(TabDébut) = n ' Le 1er élément du tableau de recheche dicho.
MiniRac = TabDébut ' Le minimum pour la mise à jour du tableau de recherche dicho.
Anc = TabDébut ' Position du dernier élément analysé dans le tableau de recherche dicho.
ValMini = Tps ' Nouveau minimum.
GoTo Element_Suivant ' Fin du traitement de n.
Loop
' Controle le débordement du maxi:
Do Until ValMaxi > Tps ' Plus rapide que If Tps >= ValMaxi Then... End If.
ref(RefMaxi) = n ' La donnée suivante de l'ancien maximum est n.
ref(n) = n ' La donnée suivante de n est n.
RefMaxi = n ' Mémorise qui est le nouveau maximum.
MaxiRac = MaxiRac + 1 ' Dernière positon dans le tableau de recherche dicho.
TabTps(MaxiRac) = n ' Le tableau de recherche dicho peut être alimenté.
Anc = MaxiRac ' Position du dernier élément analysé dans le tableau de recherche dicho.
ValMaxi = Tps ' Nouveau maximum.
GoTo Element_Suivant ' Fin du traitement de n.
Loop
' Mise à jour du tableau des données déjà classées:
While NbPassage > n ' While est plus rapide que If... Then... End If.
i = TabTps(MiniRac) ' Boucle depuis la position du plus petit élément analysé,
If MiniRac = TabDébut Then i = RefMini ' ou boucle depuis la position du minimum.
For j = MiniRac To n
TabTps(j) = i ' Mémorise la position de l'élément.
i = ref(i) ' Position de l'élément suivant.
Next j
MaxiRac = n - 1 ' Le dernier élément n'est pas utilisé.
MiniRac = MaxiRac ' Efface la position du plus petit élément analysé.
NbPassage = n * 0.3 ' Initialise le nombre de passages pour mise à jour du tableau.
NbRechercheDicho = Log(n) / Log(2) ' Nombre maximum de recherches possibles dans le tableau dicho.
If NbRechercheDicho > 5 Then MaxiDoWhile = NbRechercheDicho ' Limite pour les suites non contigües
Début = TabDébut: Fin = MaxiRac ' Bornes pour la recherche Dichotomique.
GoTo RechercheDichotomique
Wend
' Bornes pour la Recherche Dichotomique dans le tableau des données déjà classées:
Début = TabDébut: Fin = MaxiRac
' Tests complémentaires (égalités et suites immédiates):
Do Until TabDonnées(n - 1) > Tps ' Si n est >= dernier élément analysé.
Début = Anc ' Borne de début pour la recherche dicho.
Do Until Tps > TabDonnées(ref(n - 1)) ' Si n est <= élément suivant du dernier élément analysé.
ref(n) = ref(n - 1) ' Echange de la donnée suivante de n et de l'ancien élément.
ref(n - 1) = n ' n devient la donnée suivante de l'ancien élément.
TauxTest = TauxTest + 1 ' Nombre de tests efficaces.
GoTo Element_Suivant ' Fin du traitement de n.
Loop
GoTo RechercheDichotomique ' Passe à la recherche avec la nouvelle borne de début.
Loop
Fin = Anc ' Borne de fin pour la recherche dicho.
' Recherche Dichotomique dans le tableau des données déjà classées:
RechercheDichotomique:
For j = 4 To NbRechercheDicho ' Plus rapide que Do...Loop While Début + 2 < Fin
i = (Début + Fin) / 2 ' Calcule le milieu.
If Tps > TabDonnées(TabTps(i)) Then Début = i Else Fin = i
Next j
While TabDonnées(TabTps(Début + 1)) < Tps: Début = Début + 1: Wend
Anc = Début ' Solution.
i = TabTps(Anc) ' Plus proche donnée inférieure connue.
While Anc < MiniRac: MiniRac = Anc: Wend ' Plus rapide que If Anc < MiniRac Then MiniRac = Anc
' Boucle sur les indices suivants pour trouver le classement du nouvel élément:
Compteur = 0
Do
j = i ' Dernière Solution.
i = ref(i) ' Indice suivant
Compteur = Compteur + 1 ' Compte le nombre de passages infructeux.
Loop While Tps > TabDonnées(i) ' Sort si la valeur de l'indice suivant >= Tps.
NbPassage = NbPassage + Compteur
ref(n) = ref(j) ' Qui est la donnée suivante de n.
ref(j) = n ' n devient la donnée suivante de l'ancien élément.
' Gestion des suites non contigües:
While Compteur > MaxiDoWhile
TabTps(Anc - 2) = TabTps(Anc - 1)
TabTps(Anc - 1) = TabTps(Anc)
TabTps(Anc) = n
TabTps(TabDébut) = RefMini
Compteur = MaxiDoWhile
Wend
Element_Suivant:
Next n
' Alimente le taux d'efficacité des tests complémentaires:
TauxTest = TauxTest * 100 / (TabFin - TabDébut)
' Si l'option des tests complémentaires est à Faux (0):
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Else
' Boucle sur les éléments à classer sans effectuer les tests complémentaires:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For n = 2 + TabDébut To TabFin
Tps = TabDonnées(n)
' Controle le débordement du mini:
Do Until Tps > ValMini ' Plus rapide que If Tps <= ValMini Then... End If.
ref(n) = RefMini ' La données suivante de n est l'ancien minimum.
RefMini = n ' Mémorise qui est le nouveau minimum.
TabTps(TabDébut) = n ' Le 1er élément du tableau de recheche dicho.
MiniRac = TabDébut ' Le minimum pour la mise à jour du tableau de recherche dicho.
Anc = TabDébut ' Position du dernier élément analysé dans le tableau de recherche dicho.
ValMini = Tps ' Nouveau minimum.
GoTo ST_Element_Suivant ' Fin du traitement de n.
Loop
' Controle le débordement du maxi:
Do Until ValMaxi > Tps ' Plus rapide que If Tps >= ValMaxi Then... End If.
ref(RefMaxi) = n ' La donnée suivante de l'ancien maximum est n.
ref(n) = n ' La donnée suivante de n est n.
RefMaxi = n ' Mémorise qui est le nouveau maximum.
MaxiRac = MaxiRac + 1 ' Dernière positon dans le tableau de recherche dicho.
TabTps(MaxiRac) = n ' Le tableau de recherche dicho peut être alimenté.
Anc = MaxiRac ' Position du dernier élément analysé dans le tableau de recherche dicho.
ValMaxi = Tps ' Nouveau maximum.
GoTo ST_Element_Suivant ' Fin du traitement de n.
Loop
' Mise à jour du tableau des données déjà classées:
While NbPassage > n ' While est plus rapide que If... Then... End If.
i = TabTps(MiniRac) ' Boucle depuis la position du plus petit élément analysé,
If MiniRac = TabDébut Then i = RefMini ' ou boucle depuis la position du minimum.
For j = MiniRac To n
TabTps(j) = i ' Mémorise la position de l'élément.
i = ref(i) ' Position de l'élément suivant.
Next j
MaxiRac = n - 1 ' Le dernier élément n'est pas utilisé.
MiniRac = MaxiRac ' Efface la position du plus petit élément analysé.
NbPassage = 0 ' Initialise le nombre de passages pour mise à jour du tableau.
NbRechercheDicho = Log(n) / Log(2) ' Nombre maximum de recherches possibles dans le tableau dicho.
Wend
' Recherche Dichotomique dans le tableau des données déjà classées:
Début = TabDébut: Fin = MaxiRac
For j = 2 To NbRechercheDicho ' Plus rapide que Do...Loop While Début + 2 < Fin
i = (Début + Fin) / 2 ' Calcule le milieu.
If Tps > TabDonnées(TabTps(i)) Then Début = i Else Fin = i
Next j
Anc = Début ' Solution.
i = TabTps(Anc) ' Plus proche donnée inférieure connue.
While Anc < MiniRac: MiniRac = Anc: Wend ' Plus rapide que If Anc < MiniRac Then MiniRac = Anc
' Boucle sur les indices suivants pour trouver le classement du nouvel élément:
Do
j = i ' Dernière Solution.
i = ref(i) ' Indice suivant
NbPassage = NbPassage + 1 ' Compte le nombre de passages infructeux.
Loop While Tps > TabDonnées(i) ' Sort si la valeur de l'indice suivant >= Tps.
ref(n) = ref(j) ' Qui est la donnée suivante de n.
ref(j) = n ' n devient la donnée suivante de l'ancien élément.
ST_Element_Suivant:
Next n
End If
' S'il faut retourner le Classement sans le tri:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If ModeClassement = 3 Then
i = TabTps(MiniRac): If MiniRac = TabDébut Then i = RefMini
For n = MiniRac To TabFin
TabTps(n) = i
i = ref(i)
Next n
QuickRanking = TabTps()
Exit Function
End If
' Fait une copie temporaire du tableau d'origine:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Erase TabTps: ReDim Mémo(TabDébut To TabFin) As Variant
For n = TabDébut To TabFin
Mémo(n) = TabDonnées(n)
Next n
' Initialisation du tableau du classement si demandé:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If ModeClassement > 0 Then
ReDim Pos(TabDébut To TabFin) As Long
ReDim Egalités(TabDébut To TabFin) As Long
End If
' Classe les données dans l'ordre croissant:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If OrdreCroissant = True Then
i = RefMini
For n = TabDébut To TabFin
TabDonnées(n) = Mémo(i)
i = ref(i)
Next n
' S'il faut retourner le Classement où les égalités ont le même classement:
If ModeClassement = 1 Then
i = RefMini: Anc = i: NbPassage = 1
For n = TabDébut To TabFin
Pos(i) = NbPassage: NbPassage = NbPassage + 1
If Mémo(i) = Mémo(Anc) Then Pos(i) = Pos(Anc)
Anc = i: i = ref(i)
Next n
QuickRanking = Pos(): Exit Function
End If
' S'il faut retourner le Classement où les égalités distinguent l'ordre d'origine:
If ModeClassement = 2 Then
i = RefMini: Anc = i: j = TabDébut: NbPassage = 1
For n = TabDébut To TabFin
Egalités(j) = i: Anc = i: i = ref(i): j = j + 1
If Mémo(i) > Mémo(Anc) Then
If j > TabDébut + 1 Then Call QuickSort(Egalités(), TabDébut, j - 1)
For l = TabDébut To j - 1
Pos(Egalités(l)) = NbPassage: NbPassage = NbPassage + 1
Next l
j = TabDébut
End If
Next n
If j > TabDébut + 1 Then Call QuickSort(Egalités(), TabDébut, j - 1)
For l = TabDébut To j - 1
Pos(Egalités(l)) = NbPassage: NbPassage = NbPassage + 1
Next l
QuickRanking = Pos(): Exit Function
End If
' S'il faut retourner le tri sans doublons (et sans classement):
If ModeClassement = 4 Then
NbPassage = TabDébut
For n = TabDébut + 1 To TabFin
If TabDonnées(n) <> TabDonnées(n - 1) Then NbPassage = NbPassage + 1
TabDonnées(NbPassage) = TabDonnées(n)
Next n
ReDim Preserve TabDonnées(TabDébut To NbPassage)
QuickRanking = Pos(): Exit Function
End If
QuickRanking = Pos()
Exit Function
End If
' Classe les données dans l'ordre Décroissant:
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i = RefMini
For n = TabFin To TabDébut Step -1
TabDonnées(n) = Mémo(i)
i = ref(i)
Next n
' S'il faut retourner le Classement où les égalités ont le même classement:
If ModeClassement = 1 Then
i = RefMini: Anc = i: NbPassage = TabFin - TabDébut + 1
For n = TabFin To TabDébut Step -1
Pos(i) = NbPassage: NbPassage = NbPassage - 1
If Mémo(i) = Mémo(Anc) Then Pos(i) = Pos(Anc)
Anc = i
i = ref(i)
Next n
QuickRanking = Pos(): Exit Function
End If
' S'il faut retourner le Classement où les égalités distinguent l'ordre d'origine:
If ModeClassement = 2 Then
i = RefMini: Anc = i: j = TabDébut: NbPassage = TabFin - TabDébut + 1
For n = TabDébut To TabFin
Egalités(j) = i
Anc = i
i = ref(i)
j = j + 1
If Mémo(i) <> Mémo(Anc) Or n = TabFin Then
If j > TabDébut + 1 Then Call QuickSort(Egalités(), TabDébut, j - 1)
For l = TabDébut To j - 1
Pos(Egalités(l)) = NbPassage
NbPassage = NbPassage - 1
Next l
j = TabDébut
End If
Next n
QuickRanking = Pos(): Exit Function
End If
' S'il faut retourner le tri sans doublons (et sans classement):
If ModeClassement = 4 Then
NbPassage = TabDébut
For n = TabDébut + 1 To TabFin
If TabDonnées(n) <> TabDonnées(n - 1) Then NbPassage = NbPassage + 1
TabDonnées(NbPassage) = TabDonnées(n)
Next n
ReDim Preserve TabDonnées(TabDébut To NbPassage)
QuickRanking = Pos(): Exit Function
End If
QuickRanking = Pos()
Gest_Err:
If Err.Number <> 0 Then MsgBox "Erreur: " & Err.Number & " - " & Err.Description, _
vbCritical + vbOKOnly, "QuickRanking"
Err.Clear
End Function
'----------------------------------------------------------------------------------------
Private Sub QuickSort(ByRef TabDonnées() As Long, ByVal Gauche As Long, ByVal Droite As Long)
'----------------------------------------------------------------------------------------
' Avec ModeClassement = 2, utilise QuickSort optimisé pour le traitement des entiers long.
'----------------------------------------------------------------------------------------
Dim i As Long, j As Long, Temp As Long, Pivot As Long
i = Gauche
j = Droite
Pivot = TabDonnées((Gauche + Droite) / 2)
Do
While Pivot > TabDonnées(i): i = i + 1: Wend
While TabDonnées(j) > Pivot: j = j - 1: Wend
If j + 1 > i Then ' If i <= j Then
Temp = TabDonnées(i)
TabDonnées(i) = TabDonnées(j)
TabDonnées(j) = Temp
j = j - 1: i = i + 1
End If
Loop Until i > j ' Loop While i < j
If Gauche < j Then Call QuickSort(TabDonnées(), Gauche, j)
If i < Droite Then Call QuickSort(TabDonnées(), i, Droite)
End Sub
'----------------------------------------------------------------------------------------
Private Function TesterNiveauQR(ByRef MonTableau() As Variant, _
ByVal TauxConformité As Long, _
Optional ByVal PcEchantillon As Double = 0.1) As Boolean
'----------------------------------------------------------------------------------------
Dim Début As Long, Fin As Long, TailleEchantillon As Long, i As Long, l As Long
Début = LBound(MonTableau())
Fin = UBound(MonTableau())
' Initialisation des variables:
TailleEchantillon = (Fin - Début) * PcEchantillon / 100
' Controle la taille de l'échantillon pris au hasard dans la liste:
If TailleEchantillon > Fin * 0.03 Then TailleEchantillon = Fin * 0.03
If TailleEchantillon < 20 Then TesterNiveauQR = True: Exit Function
ReDim MonTest(Début To TailleEchantillon) As Variant
Do
i = Rnd() * Fin
Loop While Début + i + TailleEchantillon > Fin
For l = i To i + TailleEchantillon
MonTest(Début) = MonTableau(l): Début = Début + 1
Next l
' Compte le nombre de tests fructueux avec l'option à Vrai:
i = 0: Call QuickRanking(MonTest(), True, 3, True, i)
' Retourne Vrai si les tests sont efficaces dans au moins TauxConformité% des cas:
If i > TauxConformité Then TesterNiveauQR = True
End Function
'---------------------------------------------------------------------------------------- |
Suppression Doublons dans Variable Array VBA
Répondre avec citation
Partager