[XL-2010] Macro recherche doublons inversés

Version imprimable

10/07/2015, 10h06
sramitator

1 pièce(s) jointe(s)

[XL-2010] Macro recherche doublons inversés

Bonjour

Je cheche une solution afin de rechercher des doublons "inverses"
EN gros j'ai une colonne avec des numéros et une autre avec d'autre numéros
j'aimerai écrire un emacro qui compare la première colonne à la deuxième exemple (voir fichier joint)

A B

ACC037 CAB039

ACC121 CAB121

CAB039 ACC037

Par exemple dans ce cas je sais qu j'ai une liaison entre la première et troisième ligne car on a les même références mais inversées. J aimerai pouvoir remonter tout les "couples" de doublons sur une autre colonne

merci de votre aide
10/07/2015, 10h21
Philippe Tulliez

Bonjour,
La fonction EQUIV devrait t'aider à résoudre ton problème. Elle renvoie la position de la valeur à chercher dans une colonne ou dans une ligne.

Bonjour Sraminator, Philippe, bonjour le forum,

Une proposition par macro avec le code ci-dessous :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
 
Set O = Sheets("Feuil1") 'définit l'onglet O (à adapter)
Set PL = O.Range("A1").CurrentRegion 'définit la plage PL
Set PL = PL.Resize(PL.Rows.Count, PL.Columns.Count + 2) 'redéfinit la plage PL
TC = PL 'définit le tableau de cellules TC
For I = 1 To UBound(TC, 1) 'boucle 1 : sur toutes les lignes I du tableau de cellules TC
    For J = 1 To UBound(TC, 1) 'boucle 2 : sur toutes les lignes J du tableau de cellules TC
        If TC(I, 1) = TC(J, 3) And TC(I, 3) = TC(J, 1) Then 'condition si il y a doublon inversé
            Set DEST = IIf(O.Range("D1").Value = "", O.Range("D1"), O.Cells(Application.Rows.Count, 4).End(xlUp).Offset(1, 0)) 'définit la cellule de destination DEST
            'copie dans dest la valeur ligne I, colonne 1 et dans dest décalée d'une colonne a droite la valeur ligne I colonne 3
            DEST.Value = TC(I, 1): DEST.Offset(0, 1).Value = TC(I, 3)
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
Next I 'prochaine ligne de la boucle 1
End Sub

Bonsoir,

Code:

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
Type DoubleInV
Nb As Long
A() As String
B() As String
End Type
Sub test()
Dim Idx As Long, L As Long, R As Range, Sh As Worksheet
Dim DblInV() As DoubleInV, Dico
Set Dico = CreateObject("Scripting.dictionary")
ReDim DblInV(0)
Set Sh = Sheets("Feuil1")
Idx = Sh.Range("A" & Cells.Rows.Count).End(xlUp).Row
Set R = Sh.Range(Sh.Range("A1"), Sh.Cells(Idx, 3))
Idx = 0
For L = 1 To R.Rows.Count
    If Dico.Exists(R(L, 1).Value & "_" & R(L, 3).Value) = False Then
      Idx = Idx + 1
      Dico.Add R(L, 1).Value & "_" & R(L, 3).Value, Idx
      If Dico.Exists(R(L, 3).Value & "_" & R(L, 1).Value) = False Then Dico.Add R(L, 3).Value & "_" & R(L, 1).Value, Idx
      ReDim Preserve DblInV(Idx)
    End If
    ReDim Preserve DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).A(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb)
    ReDim Preserve DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).B(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb)
    DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).A(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb) = R(L, 1).Value
    DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).B(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb) = R(L, 3).Value
    DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb = DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb + 1
 
Next
For L = 1 To UBound(DblInV)
    If DblInV(L).Nb > 1 Then
 
        Idx = Sh.Range("D" & Cells.Rows.Count).End(xlUp).Row + 1
        If Idx = 2 Then Idx = 1
        Sh.Range(Sh.Cells(Idx, "D"), Sh.Cells(Idx, "D").Offset(DblInV(L).Nb - 1)) = Application.WorksheetFunction.Transpose(DblInV(L).A)
        Sh.Range(Sh.Cells(Idx, "E"), Sh.Cells(Idx, "E").Offset(DblInV(L).Nb - 1)) = Application.WorksheetFunction.Transpose(DblInV(L).B)
    End If
Next
End Sub

Bonsoir le forum, :P

A tester :
Tes données en colonne A et B à partir de la ligne 1
Restitution en Feuil2

Code:

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
Sub Recherche_Doublons()
Dim a, b(), i As Long
    a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = VBA.Array(a(i, 1), a(i, 2))
            End If
        Next
        a = Sheets("Feuil1").Range("b1", Range("b" & Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(a, 1)
            If .exists(a(i, 1)) Then    '
                n = n + 1
                b(n, 1) = .Item(a(i, 1))(0)
                b(n, 2) = .Item(a(i, 1))(1)
            End If
        Next
        If n > 1 Then
            Sheets("Feuil2").Range("a1").Resize(n, 2).Value = b
        Else
            MsgBox "aucune donnée"
        End If
    End With
End Sub

klin89

18/07/2015, 01h10
patricktoulon

heu

Bonsoir
tu veux remonter une paire ou les deux voir les autres (doublons )??????

je vois bien les deux dernier exemple que l'on a proposé mais beaucoup plus simple
1 seul dico
et teste si exists cel1 et cel2 and cel2 et cel1 en utilisant pourquoi pas "strreverse" sur la concaténation des deux
tout simplement
18/07/2015, 15h45
Invité

Bonjour Patrick,
Oui c'est exactement l'idée de ma source, un seule dico avec une concaténation inversé!

Ainsi doublon, triplons , quadruplons sont recensés.
18/07/2015, 18h47
patricktoulon

re

Bonjour durupt

oui j'ai fait un petit essai hier soir et j'ai eu une surprise les valeur correspondent a des valeur (hex) apparemment

et si je fait quelque chose =lavaleur > ce quelque chose devient une autre interprétation de la valeur c'est assez étonnant en même temps pas tant que ca

cstr a volonté
18/07/2015, 19h10
Invité

Oui tu as raison, dans mes tests j'ai pas vue de conversation de type, la chance sens doute!

re ok j'ai compris en fait il y avait un grand trou vide dans la plage c'est pour ca que je voyais des references que je n'avais pas vu

en fait j'ait fait beaucoup plus simple que toi mais vraiment beaucoup plus simple
comme je l'ai dis 1 dico 2 variable tableau 2 variable long point barre

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Option Base 1
Sub test()
    Dim dico, tablo1, tablo2, a As Long, i As Long, verlan As String    ' variable
    Set dico = CreateObject("Scripting.dictionary")    'on créé le dictionaire
    tablo1 = Range(Cells(1, 1), Cells(Rows.Count, 3).End(xlUp))    'on met la plage de cellules dans un tableau
    ReDim tablo2(UBound(tablo1), 2)    'on redimentionne le tablo2 identique au ta  blo1
    For i = 1 To UBound(tablo1, 1)    'on boucle
        verlan = tablo1(i, 3) & "_" & tablo1(i, 1)    'verlan devient la valeur a l'envers
        If dico.exists(tablo1(i, 1) & "_" & tablo1(i, 3)) Or dico.exists(verlan) Then    'on teste des deux coté
            a = a + 1: tablo2(a, 1) = tablo1(i, 1): tablo2(a, 2) = tablo1(i, 3)    'si oui alors on mets les deux dans le nouveau tablo
            a = a + 1: tablo2(a, 1) = tablo1(i, 3): tablo2(a, 2) = tablo1(i, 1)    'idem
        End If
        dico(tablo1(i, 1) & "_" & tablo1(i, 3)) = ""    ' on met de toute maniere l'exemplaire original dans le dico
    Next
    Cells(1, 4).Resize(UBound(tablo2), 2) = tablo2    ' on place dans un cell resize le tablo2
End Sub

tout simplement !;)

pourquoi moins de ligne
tout simplement
quand je fait dico(trucmachinchose)="" 10 ou 100 fois il y aura toujours qu'un seul item pas la peine de re tester comme tu fait a la différence de dico add
parce que si l'item existe seul changera ce qu'il y a dans les guillemets si il n'existe pas l'item est ajouté

Bonjour.

Citation:

Envoyé par sramitator

J aimerai pouvoir remonter tout les "couples" de doublons sur une autre colonne

Code:

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
Sub gb()
 Columns("F:J").Clear
 
 d = Range("A" & Rows.Count).End(xlUp).Row
 
 For i = 1 To d
  Cells(i, "F") = Cells(i, "C") & " " & Cells(i, "A")
 Next
 
 For i = 1 To d
  If Cells(i, "F") = "" Then
  Else
   a = Cells(i, "A") & " " & Cells(i, "C")
   Set R = Columns("F").Find(what:=a, LookIn:=xlFormulas, LookAt:=xlWhole, SearchFormat:=False, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
 
   If Not R Is Nothing Then
 
    lig = lig + 1: Cells(lig, "I") = Cells(i, "A")
                   Cells(lig, "J") = Cells(i, "C")
                   Cells(lig, "H") = i
 
    lig = lig + 1: Cells(lig, "I") = Cells(R.Row, "A")
                   Cells(lig, "J") = Cells(R.Row, "C")
                   Cells(lig, "H") = R.Row
 
    R.Value = ""
 
   End If
 
  End If
 Next
 
End Sub

EDIT: Voici la version 2

Code:

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
Sub gb2()
 
 Columns("A:C").Select
 With Selection.Interior
        .Pattern = xlNone
 End With
 
 Columns("F:J").Clear
 
 d = Range("A" & Rows.Count).End(xlUp).Row
 
 For i = 1 To d
  Cells(i, "F") = Cells(i, "C") & " " & Cells(i, "A")
 Next
 
 For i = 1 To d
  If Cells(i, "F") = "" Then
  Else
   a = Cells(i, "A") & " " & Cells(i, "C")
 
   Set R = Columns("F").Find(what:=a, LookIn:=xlFormulas, LookAt:=xlWhole, SearchFormat:=False, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
 
   If Not R Is Nothing Then
 
    If R.Row = i Then Set R = Columns("F").FindNext(R)
 
    If R.Row <> i Then
 
Cells(i, "A").Interior.Color = 65000
Cells(R.Row, "C").Interior.Color = 65000
 
    lig = lig + 1: Cells(lig, "I") = Cells(i, "A")
                   Cells(lig, "J") = Cells(i, "C")
                   Cells(lig, "H") = i
 
    lig = lig + 1: Cells(lig, "I") = Cells(R.Row, "A")
                   Cells(lig, "J") = Cells(R.Row, "C")
                   Cells(lig, "H") = R.Row
 
 
    R.Value = ""
    Cells(i, "F") = ""
    End If
   End If
 
  End If
 Next
 
End Sub

Bonjour à tous, :P

Après analyse des différentes réponses :

Code:

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
Option Explicit
 
Sub Recherche_Doublons()
Dim a, b(), i As Long, txt As String
    With Range("A1").CurrentRegion.Resize(, 3)
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 3))
    End With
    ReDim b(1 To UBound(a, 1), 1 To 2)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)))
            If Not .exists(txt) Then
                .Item(txt) = VBA.Array(a(i, 2), a(i, 1))
            End If
        Next
        With Range("A1").CurrentRegion.Resize(, 3)
            a = Application.Index(.Value, Evaluate("row(1:" & _
                                                   .Rows.Count & ")"), Array(3, 1))
        End With
        For i = 1 To UBound(a, 1)
            txt = Join$(Array(a(i, 1), a(i, 2)))
            If .exists(txt) Then    '
                n = n + 1
                b(n, 1) = .Item(txt)(0)
                b(n, 2) = .Item(txt)(1)
            End If
        Next
        If n > 1 Then
            Sheets("Feuil2").Range("a1").Resize(n, 2).Value = b
        Else
            MsgBox "aucune donnée"
        End If
    End With
End Sub

klin89

19/07/2015, 14h52
Philippe Tulliez

Bonjour,
Ce qui est amusant c'est que l'initiateur de la discussion (sramitator) semble aux abonnés absents. Aucune réaction de sa part.
19/07/2015, 18h04
patricktoulon

re

bonjour a tous
oui philippe c'est vrai mais le terme amusant n'est pas tout a fait mon ressenti :mouarf:
c'est pas grave cela peut servir a d'autre

il devrait avoir un system qui verifie si la discussion a eu la visite de son auteur dans un intervalle de temps
apres verification si un temps defini est depassé la discussion est cochée résolue ou supprimée
ca en ferait réfléchir plus d'un!!!
19/07/2015, 18h18
Marc-L

Salut !

Comme sur les sites où le code balisé et les pièces jointes ne sont pas affichés sans se loguer …
19/07/2015, 19h51
Philippe Tulliez

Bonjour Patrick,

Citation:

oui philippe c'est vrai mais le terme amusant n'est pas tout a fait mon ressenti

J'aurais dû effectivement placer le mot "amusant" entre guillemets.
19/07/2015, 21h10
patricktoulon

re

re
bonjour MarcL

Citation:

Salut !

Comme sur les sites où le code balisé et les pièces jointes ne sont pas affichés sans se loguer …

????????????
je vois pas bien ce qui pourrais empecher l'auteur sachant que l'on ne peut pas poster sans se loguer

ou alors un message du meme type que l'on a quand on a recu un MP
"vous avec recu des reponse dans le post "blablabla" #x45vc5 depuis x jours que vous n'avez pas lu

ca enerve un peu mais c'est top
ca me le fait tout le temps pour mes MP :mouarf::mouarf:
et le pire c'est que si je clique sur annuler des que je change de page (forum/ou reponse dans un post ) allez hop le message reviens
ha!!!! ca enerve :c'est ca qu'il faut :mouarf:
:ptdr:

je ne parle meme pas de ceux qui viennent chercher des reponses et qui les récupères sans en avertir les participants
ni merci ni M....
ce qui est peut etre le cas
20/07/2015, 00h39
Invité

1 pièce(s) jointe(s)

Bonjour,
De toute évidence juillet aout n'est pas la période idéale pour entamer une correspondance, peut-être recevrons nous une carte postale!

X Je suis ICI
20/07/2015, 15h02
patricktoulon

re

:ptdr::ptdr::ptdr::ptdr::ptdr::ptdr::ptdr:
sans vouloir faire de jeux de mots au moins tu est a l'ombre :mouarf:

A	B
ACC037	CAB039
ACC121	CAB121
CAB039	ACC037