XL 2016 Idées pour recherche de doublons complexe

Tom33700 · 30 Mai 2022

Bonjour,

Je cherche une solution pour effectuer une recherche de doublon complexe via VBA.

Je m'explique. Dans une colonne donnée (on va dire A), je peux trouver des nombres que j'appelle "indexes".
Un index est un chiffre partant de 0 incrémenté de 10. Donc on peut trouver dans cette colonne les nombres 10, 20, 30, 40, 50, etc...
Dans cette colonne A, je peux avoir des cellules avec un seul index mais aussi des cellules avec plusieurs indexes. Dans ce cas, chaque index est séparé par un "|" (barre verticale obtenue avec ALT Gr - 6)

Je peux donc avoir par exemple ça :

10
20
30|40|50
60
70
80|90|100

Ce que je cherche à faire c'est de créer une macro capable de détecter un index qui se trouverai dans 2 cellules différentes. Par exemple :

10
20
30|40|50
60
10
70
80|90|100

Dans ce cas, c'est assez simple puisqu'il suffit de comparer 2 cellules. Si elles sont égales, alors on détecte le doublon.
Là où je flanche, c'est dans ce cas là :

10
20
30|40|50
60
10|110|120
70
80|90|100

Si l'index se situe dans une cellule comprenant d'autres indexes, comment le détecter? Comment aussi ne pas détecter les faux doublons comme 10 et 100. 100 contient 10 mais n'est pas un doublon...

Auriez-vous des pistes svp?
A savoir que la liste d'indexes peut être longue...

Merci!

Tom33700 · 31 Mai 2022

Efgé à dit:
Re
Effectivement l'absence de doublon n'était pas prévue.
C'est chose faite avec un message de fin de traitement dans ce cas.

Cordialement

PARFAIT!
Merci beaucoup pour ton aide, ta réactivité et ton savoir-faire. Je vais pouvoir continuer à maquetter mon projet!
Bonne journée!

JHA · 30 Mai 2022

Bonjour à tous,

Un début de piste avec données/convertir
Et une MFC pour trouver les doublons.

JHA

Efgé · 30 Mai 2022

Bonjour le forum, le fil, Bonjour @JHA
Au cas où...

VB:

Sub doublonsAdresses()
Dim i&, J&, Cpt&
Dim Dico As Object
Dim TTmp As Variant, TReport As Variant, K As Variant
Dim Plg As Range, C As Range

Set Dico = CreateObject("scripting.dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(3))
End With

For Each C In Plg
    TTmp = Split(C, "|")
    For J = LBound(TTmp) To UBound(TTmp)
        Cpt = Cpt + 1
        Dico(TTmp(J)) = Dico(TTmp(J)) & ";" & C.Address
    Next J
Next C

i = 0

ReDim TReport(1 To Cpt, 1 To 2)
For Each K In Dico.keys
    TTmp = Split(Dico(K), ";")
    If UBound(TTmp) > 1 Then
        i = i + 1
        TReport(i, 1) = K
        TReport(i, 2) = Dico(K)
    End If
Next K

Plg.Offset(0, 2).Resize(i, 2).Value = TReport

End Sub

Cordialement

EDIT : Avec le code dans un bouton en pièce jointe

Tom33700 · 30 Mai 2022

Efgé à dit:

Bonjour le forum, le fil, Bonjour @JHA
Au cas où...

VB:

Sub doublonsAdresses()
Dim i&, J&, Cpt&
Dim Dico As Object
Dim TTmp As Variant, TReport As Variant, K As Variant
Dim Plg As Range, C As Range

Set Dico = CreateObject("scripting.dictionary")
With Sheets("Feuil1")
    Set Plg = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(3))
End With

For Each C In Plg
    TTmp = Split(C, "|")
    For J = LBound(TTmp) To UBound(TTmp)
        Cpt = Cpt + 1
        Dico(TTmp(J)) = Dico(TTmp(J)) & ";" & C.Address
    Next J
Next C

i = 0

ReDim TReport(1 To Cpt, 1 To 2)
For Each K In Dico.keys
    TTmp = Split(Dico(K), ";")
    If UBound(TTmp) > 1 Then
        i = i + 1
        TReport(i, 1) = K
        TReport(i, 2) = Dico(K)
    End If
Next K

Plg.Offset(0, 2).Resize(i, 2).Value = TReport

End Sub

Cordialement

EDIT : Avec le code dans un bouton en pièce jointe

Merci pour ces réponses rapides!
Alors oui en effet ça fonctionne à merveille!
Par contre, pourrais-tu m'expliquer un peu ton code STP? Je ne suis pas sûr d'avoir tout saisi et je voudrais pouvoir l'adapter...
Merci encore!

Efgé · 30 Mai 2022

Re
En pièce jointe le code commenté.

Cordialement

Tom33700 · 30 Mai 2022

Efgé à dit:
Re
En pièce jointe le code commenté.

Cordialement

C'est génial! Merci pour cette aide précieuse!
J'ai appris des choses!
Je vais adapter tous ça!

MERCI!!!

Tom33700 · 30 Mai 2022

Efgé à dit:
Re
En pièce jointe le code commenté.

Cordialement

Une petite question STP.
J'adapte ton code à mes besoins.
Au lieu de récupérer l'adresse complète de la cellule, je ne récupère que le numéro de ligne :

VB:

'La valeur de la clé est l'adresse de la cellule
        'concaténée le cas échéant avec les précédentes avec un ; en séparation
        Dico(TTmp(J)) = Dico(TTmp(J)) & ";" & C.Row

Lorsque tu crées le tableau final, j'aimerai mettre en surbrillance les lignes où les indexes sont en double.
Mais je ne sais pas comment extraire chaque ligne de Dico(K)

VB:

    If UBound(TTmp) > 1 Then
        'on incrémente i
        i = i + 1
        'Le tableau final ligne i colonne 1 = la clé (l'index pour toi)
        TReport(i, 1) = K
        'Le tableau final ligne i colonne 2 = la valeur de la clé
        TReport(i, 2) = Dico(K)
        'et mettre en surbrillance chaque ligne en erreur
        Sheets("SPL").Cells(???, 9).Interior.Color = RGB(255, 0, 0)

Merci pour ton aide!

Efgé · 30 Mai 2022

Re
Il est temps de déposer un fichier exemple anonyme et significatif pour voir de quoi il retourne.

Cordialement

Tom33700 · 30 Mai 2022

Efgé à dit:
Re
Il est temps de déposer un fichier exemple anonyme et significatif pour voir de quoi il retourne.

Cordialement

Voici le fichier simplifié.

Pour m'expliquer :
Dans l'onglet SPL, je compte le nombre de cellules non vidse colonne C pour connaître le nombre de lignes à tester.
Je crée dans la macro un onglet "error report" dans lequel je viens répertorier mes erreurs.
Pour chaque erreur, je référencie la ligne concernée dans cet onglet et dans l'onglet SPL je mets en surbrillance les erreurs.

Dans le cas du code que tu as fais @Efgé, je voudrais donc avoir :
- onglet SPL : les indexes en doubles en surbrillance
- Onglet erreur report : Le numéro d'index en erreur colonne A. Et en colonne B les numéros de lignes des erreur avec éventuellement un lien hypertexte (quand je clique sur la ligne en erreur, il me renvoi vers l'index à la bonne ligne de l'onglet SPL). mais je suppose que cela impose autant de colonnes que de nombre de lignes en erreur pour un index donné, non?

Merci pour ton aide!

Efgé · 30 Mai 2022

Re
J'ai changé pas mal de choses.
Regarde.

Pour les liens hypertexte, c'est un autre problème. Il faudrait faire un lien par erreur et par ligne trouvée
Ca sent l'usine à gaz...

Cordialement

Tom33700 · 30 Mai 2022

Efgé à dit:
Re
J'ai changé pas mal de choses.
Regarde.

Pour les liens hypertexte, c'est un autre problème. Il faudrait faire un lien par erreur et par ligne trouvée
Ca sent l'usine à gaz...

Cordialement

C'est bien ce que je me disais pour les liens hypertextes...
Pour le reste c'est nickel, je te remercie beaucoup!!!
Je vais aller exploiter tout ça.

Merci pour ton aide!

Tom33700 · 30 Mai 2022

Tom33700 à dit:
C'est bien ce que je me disais pour les liens hypertextes...
Pour le reste c'est nickel, je te remercie beaucoup!!!
Je vais aller exploiter tout ça.

Merci pour ton aide!

Je viens juste de me rendre compte d'un truc.
S'il n'y a pas d'erreur, le code bloque au moment de recopier le tableau (sur la dernière ligne) :

VB:

With Sheets("Error Report")
    'On vide les cellules
    .Range(.Cells(2, 1), .Cells(Cpt, 2)).ClearContents
    'on colle le tableu sur une hauteur de i lignes sur deux colonnes
    .Cells(2, 1).Resize(i, 2).Value = TReport

Efgé · 30 Mai 2022

Re
As tu une Sheets("Error Report") ?
Le même nom exactement ?

Cordialement

Tom33700 · 31 Mai 2022

Efgé à dit:
Re
As tu une Sheets("Error Report") ?
Le même nom exactement ?

Cordialement

Bonjour,

Oui en effet j'ai bien une sheet "Error Report"...

Efgé · 31 Mai 2022

Bonjour
Peux tu mettre un fichier exemple qui présente le souci ?

Cordialement

XL 2016 Idées pour recherche de doublons complexe

Tom33700

XLDnaute Nouveau

Tom33700

JHA

XLDnaute Barbatruc

Pièces jointes

Efgé

XLDnaute Barbatruc

Pièces jointes

Tom33700

XLDnaute Nouveau

Efgé

XLDnaute Barbatruc

Pièces jointes

Tom33700

XLDnaute Nouveau

Tom33700

XLDnaute Nouveau

Efgé

XLDnaute Barbatruc

Tom33700

XLDnaute Nouveau

Pièces jointes

Efgé

XLDnaute Barbatruc

Pièces jointes

Tom33700

XLDnaute Nouveau

Tom33700

XLDnaute Nouveau

Efgé

XLDnaute Barbatruc

Tom33700

XLDnaute Nouveau

Efgé

XLDnaute Barbatruc

Discussions similaires