Suppression Doublons dans Variable Array VBA

**Vb.pix** · 09/12/2019, 16h22

Bonjour à tous !

Je fais appel à vous car je bloque... J'ai un tableau de données (logique jusqu'ici...) pour lesquelles j'ai notamment un matricule et un numéro de chantier, sur plus de 800 lignes et une vingtaine de colonnes (voué à évoluer).

Pour un matricule donné, je cherche à travailler sur chaque ligne :

Vérification que le matricule recherché est le matricule de la ligne,
Récupération du numéro de la ligne vers une variable array(),
Récupération du numéro de chantier vers une autre variable array(),
Création d'un sous-tableau par numéro de chantier.

J'ai bien récupéré les données dans les array() (Que ce soit numéro de ligne ou numéro de chantier) mais je bloque pour supprimer les doublons dans l'array de numéro de chantier : il y a plusieurs lignes avec le combo matricule - numéro de chantier, par la suite, je n'ai besoin du numéro de chantier qu'une seule fois.

Auriez-vous une idée de la faisabilité?

Pour un peu plus de matière, voilà ce que j'utilise (le code parcours les 800 lignes)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
For CompteurLigne = 1 To n ' Pour chaque ligne
 
            If WsBdd.Cells(PlageDeRechercheDesChantiers.Cells(CompteurLigne).Row, 1).Value = Matricule Then ' Si le matricule de la BDD correspond au matricule demandé...
 
                TabNumLignes(CompteurNumLignes) = CStr(PlageDeRechercheDesChantiers.Cells(CompteurLigne).Row) ' Contient le numéro de la ligne
                CompteurNumLignes = CompteurNumLignes + 1
 
                TabNumChantiers(CompteurNumChantiers) = CStr(PlageDeRechercheDesChantiers.Cells(CompteurLigne).Value) ' Contient le numéro du chantier
                CompteurNumChantiers = CompteurNumChantiers + 1
 
            End If
        Next CompteurLigne

Merci !

Vincent

**Menhir** · 09/12/2019, 17h03

Pour supprimer les doublons, utilise Ruban Données > Supprimer les doublons.
Tu ne coches que les colonnes correspondant au matricule et au numéro de chantier.

Si tu veux le faire en VBA, c'est la méthode RemoveDuplicates de Range.
Lire ça : https://msdn.microsoft.com/fr-fr/lib...3(v=office.15)

**Vb.pix** · 09/12/2019, 17h08

Bonjour !

Je souhaite le faire en VBA et dans une variable. Celles-ci ne sont jamais écrites "en dur" dans une feuille. Je ne peux pas utiliser RemoveDuplicate dans mon cas

Vincent

**boisgontierjacques** · 09/12/2019, 17h41

Bonjour,

Pour éliminer les doublons dans un Array(), l'objet Dictionary est très rapide?

Boisgontier

**laurent_ott** · 10/12/2019, 12h00

Bonjour.
Pour supprimer les doublons de données mises en mémoire, j'utilise QuickRanking (voir les tomes 1 et 6 dans ma signature) qui peut marcher sur des centaines de milliers de données mémorisées.

Dans cet exemple :
- les données sont lues en colonne A (mais tes numéros de chantiers sont déjà mémorisés, c'est juste pour expliquer comment utiliser TabDonnées) et mémorisées dans TabDonnées ;
- TabDonnées est purgé des doublons ;
- les éléments restant dans TabDonnées sont affichés pour information en colonne B.

Cordialement.

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
 
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
'----------------------------------------------------------------------------------------

**Vb.pix** · 11/12/2019, 09h53

Bonjour !

Merci à vous d'avoir pris le temps de me répondre.

J'ai étudié la question et j'en suis arrivé à utiliser les dictionnaires afin de repérer les doublons.

J'ai donc une fonction (qui n'est surement pas efficiente mais qui fonctionne aujourd'hui):

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
 
Public Function SupprLesDoublonsChantiers(ListeDesChantiers)
 
    Dim dico As New Scripting.Dictionary
    Dim ChantiersSansDoublons()
    ReDim ChantiersSansDoublons(0 To UBound(ListeDesChantiers))
 
    Dim i, j As Integer
    j = 0
    For i = 0 To UBound(ListeDesChantiers) - 1
 
        If Not dico.Exists(ListeDesChantiers(i)) Then    
            dico.Add (ListeDesChantiers(i)), 0
            ReDim Preserve ChantiersSansDoublons(0 To i)
            ChantiersSansDoublons(j) = ListeDesChantiers(i)
            j = j + 1
        End If    ' fin de condition sur l'existance de l'element
 
    Next
 
    SupprLesDoublonsChantiers = ChantiersSansDoublons
End Function

Vincent

**boisgontierjacques** · 11/12/2019, 11h31

Bonjour,

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub essai()
  Tbl = [A2:B15].Value
  Tbl2 = SansDoublonsArray(Tbl)
  [D2].Resize(UBound(Tbl2), 1) = Tbl2
End Sub
 
Function SansDoublonsArray(a)
  Set mondico = CreateObject("Scripting.Dictionary")
  mondico.CompareMode = vbTextCompare
  For Each c In a
    If Not mondico.Exists(c) And c <> "" Then mondico(c) = ""
  Next c
  SansDoublonsArray = Application.Transpose(mondico.keys)
End Function

On peut les obtenir triés.

Boisgontier

**laurent_ott** · 11/12/2019, 15h45

Envoyé par boisgontierjacques

Bonjour.
J'ai testé le code (qui est très optimisé et très intéressant) en mettant des nombres aléatoires en colonne A compris entre 10.000 et 99.999 (sur plusieurs milliers de lignes), mais surprise... ça plante quand le résultat sans doublon est supérieur à 65.000 solutions, ou plus exactement, le résultat n'est pas le bon !
Est-ce qu'il y a une documentation officielle qui confirme mes tests ?

Pour le cas de "Vb.pix" ça ne pose pas de problème, mais pour ceux qui voudraient récupérer ce code ça risque d'être dangereux s'ils l'appliquent sur de grandes bases.

Bref, tout ça pour dire qu'il faut peut-être mettre des réserves sur ce code quant à la volumétrie qu'il est capable de gérer.
Et c'est pour cela que je recommande l'usage de QuickRanking.

Cordialement.

**boisgontierjacques** · 11/12/2019, 17h49

Les anciennes versions n'acceptent pas Application.Transpose() au delà de 65000. Je l'ai supprimé.
L'essai porte sur 120.000 items
Dictionary élimine les doublons naturellement. Il n'y a pas besoin d'un logiciel additif pour gérer ça.

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
Sub essai()
  Application.ScreenUpdating = False
  Tbl = [A2:B70000].Value
  Tbl2 = SansDoublonsArray(Tbl)
  'For i = LBound(Tbl2) To UBound(Tbl2)
  '  Cells(i + 2, "d") = Tbl2(i)
  'Next i
End Sub
 
Function SansDoublonsArray(a)
  Set mondico = CreateObject("Scripting.Dictionary")
  mondico.CompareMode = vbTextCompare
  For Each c In a
    If Not mondico.Exists(c) And c <> "" Then mondico(c) = ""
  Next c
  SansDoublonsArray = mondico.keys
End Function

Boisgontier

**laurent_ott** · 12/12/2019, 10h45

Bonjour.

Envoyé par boisgontierjacques

Les anciennes versions n'acceptent pas Application.Transpose() au delà de 65000

Effectivement, je n'avais pas précisé, mes tests ont été fait avec Excel 2010 et Excel 2016 (32 bits).

Envoyé par boisgontierjacques

L'essai porte sur 120.000 items

J'ai fait des tests (avec Excel 2016) sur 1 million de lignes, (sans l'affichage du résultat qui reste en mémoire dans tbl2) :
- le traitement avec SansDoublonsArray prend 30,9 secondes (9,3 secondes pour 500000 lignes) et le résultat n'est pas trié.
- le traitement avec QuickRanking prend 2,6 secondes (1,1 seconde pour 500000 lignes) et le résultat est trié par ordre croissant.

Envoyé par boisgontierjacques

Dictionary élimine les doublons naturellement. Il n'y a pas besoin d'un logiciel additif pour gérer ça.

QuickRanking n'est pas un logiciel additif, c'est une fonction développée en VBA, tout simplement, mise à la disposition de tous depuis le tome 1 publié en 2016 sur Developpez.com.

Envoyé par boisgontierjacques

On peut les obtenir triés

je suis curieux de voir la solution proposée et le temps de traitement obtenu.

Cordialement.

**boisgontierjacques** · 12/12/2019, 11h06

Bonjour,

1- Quand on gère 1.000.000 de lignes, on n'utilise pas Excel mais un SGBD.
2- Pour la portabilité, je n'utilise que des fonctions standards propes au logiciel utilisé.

Boisgontier

Suppression Doublons dans Variable Array VBA [XL-2016]

Macros et VBA Excel

Discussions similaires

Partager

Partager