Microsoft 365 Recherche de manquants entre deux colonnes

Faroyo

XLDnaute Junior
Bonjour,
je suis à la recherche d'une ame chariatable qui pourra m'aider à resoudre mon Pb.
L'ojectif et de pouvoir comparer deux colonnes (A et B) remplies avec des données provenant de deux sources differentes.
J'aimerai pouvoir comparer les deux colonnes. Mettre en evidence les valeurs de la colonne A qui ne sont pas dans B et inversement, valeurs de B pas dans A.
Mettre en evidence les differences entre les colonnes et ajouter aux les colonnes les manquants pour que colonne A = colonne B

J'ai un bout de code mais il ne fonctionne correctement. Si une valeur existe dans A et pas dans B pas de pb. Idem si existe dans B mais pas dans A.
Le pb commence lorsque la valuer existe dans A et dans B mais son occurence est differente.
Ex: si j'ai 3x la valeur 1959 dans la colonne A et que 2 fois dans la colonne B la macro ne le voit pas.

Y aurait-il un moyen de verifier cette occurence et dans tenir compte.
Merci
 

Pièces jointes

  • test.xlsm
    23.8 KB · Affichages: 17
Solution
ha ok, c'est pas encore ce que j'avais pensé..
comme j'étais parti sur autre chose, je te livre quand meme la solution que j'avais:
je croyais que tu allais finir par demander d'inserer les éléments manquants d'une colonne à l'autre pour que les deux soient strictement identiques au final: ce qui donnait ca
VB:
Sub Comp3()
Application.ScreenUpdating = False
With Sheets("Test")
    fin = .UsedRange.Rows.Count
    For i = 2 To fin
        If .Range("A" & i) <> .Range("B" & i) Then
            If .Range("A" & i) < .Range("B" & i) Then
                .Range("B" & i).Insert shift:=xlDown 'on insère une ligne pour la donnée manquante
                fin = fin + 1
            Else
                .Range("A" & i).Insert shift:=xlDown 'on...

vgendron

XLDnaute Barbatruc
Hello

un bout de code pour comparer tes deux colonnes et identifier les "manquants" d'une colonne à l'autre..
mais. je ne sais pas pourquoi, meme si tu ne l'as pas clairement exprimé, je pressent que ce n'est pas ce dont tu as besoin...
VB:
Sub comp2()
Dim tabD1() As Variant
Dim tabD2() As Variant

With Sheets("Test")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    tabD1 = .Range("A2:A" & fin).Value
    fin = .Range("B" & .Rows.Count).End(xlUp).Row
    tabD2 = .Range("B2:B" & fin).Value

For i = LBound(tabD1, 1) To UBound(tabD1, 1)
    AinB = False
    For j = LBound(tabD2, 1) To UBound(tabD2, 1)
        If tabD1(i, 1) = tabD2(j, 1) Then
            AinB = True
            Exit For
        End If
        
    Next j
    If AinB Then
        .Range("D" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD1(i, 1)
    Else
        .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD1(i, 1)
    End If
Next i
For i = LBound(tabD2, 1) To UBound(tabD2, 1)
    BinA = False
    For j = LBound(tabD1, 1) To UBound(tabD1, 1)
        If tabD2(i, 1) = tabD1(j, 1) Then
            BinA = True
            Exit For
        End If
        
    Next j
    If BinA Then
        '.Range("D" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD1(i, 1) 'cas déjà traité avec la boucle précédente
    Else
        .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD2(i, 1)
    End If
Next i
End With
End Sub
 

Faroyo

XLDnaute Junior
Hello

un bout de code pour comparer tes deux colonnes et identifier les "manquants" d'une colonne à l'autre..
mais. je ne sais pas pourquoi, meme si tu ne l'as pas clairement exprimé, je pressent que ce n'est pas ce dont tu as besoin...
VB:
Sub comp2()
Dim tabD1() As Variant
Dim tabD2() As Variant

With Sheets("Test")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    tabD1 = .Range("A2:A" & fin).Value
    fin = .Range("B" & .Rows.Count).End(xlUp).Row
    tabD2 = .Range("B2:B" & fin).Value

For i = LBound(tabD1, 1) To UBound(tabD1, 1)
    AinB = False
    For j = LBound(tabD2, 1) To UBound(tabD2, 1)
        If tabD1(i, 1) = tabD2(j, 1) Then
            AinB = True
            Exit For
        End If
       
    Next j
    If AinB Then
        .Range("D" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD1(i, 1)
    Else
        .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD1(i, 1)
    End If
Next i
For i = LBound(tabD2, 1) To UBound(tabD2, 1)
    BinA = False
    For j = LBound(tabD1, 1) To UBound(tabD1, 1)
        If tabD2(i, 1) = tabD1(j, 1) Then
            BinA = True
            Exit For
        End If
       
    Next j
    If BinA Then
        '.Range("D" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD1(i, 1) 'cas déjà traité avec la boucle précédente
    Else
        .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0) = tabD2(i, 1)
    End If
Next i
End With
End Sub
Merci pour cette reponse Vgendron mais oui effectivement, bien que fonctionnnanat parfaitement pour rechercher les manquants il resoud pas le pb de l'occurence.
1624969351253.png



Dans la colonne A j'ai 3x la valeur 1959 mais que 2x dans la colonne B. une occurence de la valeur 1959 est donc manquante dans la colonne B. Il faudrait donc retrouver 1x 1959 dans "F"
Pour la valeur 12009 est presente 5x dans A mais que 3x dans B. Elle devrait donc apparaitre 2x dans F
Volia en gros le pb a resoudre en esperent avoir ete plus clair

Merci
 

Pièces jointes

  • 1624969110057.png
    1624969110057.png
    28.2 KB · Affichages: 15

vgendron

XLDnaute Barbatruc
ha ok, c'est pas encore ce que j'avais pensé..
comme j'étais parti sur autre chose, je te livre quand meme la solution que j'avais:
je croyais que tu allais finir par demander d'inserer les éléments manquants d'une colonne à l'autre pour que les deux soient strictement identiques au final: ce qui donnait ca
VB:
Sub Comp3()
Application.ScreenUpdating = False
With Sheets("Test")
    fin = .UsedRange.Rows.Count
    For i = 2 To fin
        If .Range("A" & i) <> .Range("B" & i) Then
            If .Range("A" & i) < .Range("B" & i) Then
                .Range("B" & i).Insert shift:=xlDown 'on insère une ligne pour la donnée manquante
                fin = fin + 1
            Else
                .Range("A" & i).Insert shift:=xlDown 'on insère une ligne pour la donnée manquante
                fin = fin + 1
            End If
        End If
    Next i
    For i = 2 To fin
        If .Range("A" & i) = "" Then
            '.Range("A" & i) = .Range("B" & i) 'on complète la colonne
            .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0) = .Range("B" & i)
        End If
        If .Range("B" & i) = "" Then
            '.Range("B" & i) = .Range("A" & i) 'on complète la colonne
            .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0) = .Range("A" & i)
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub
 

vgendron

XLDnaute Barbatruc
et pour le fun une solution à base de dictionaire pour juste donner les manquants SANS modifier les colonnes de départ
VB:
Sub Comp4()

Set dicoD1 = CreateObject("Scripting.Dictionary")
Set dicoD2 = CreateObject("Scripting.Dictionary")

With ActiveSheet
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    For i = 2 To fin
        clé = .Range("A" & i)
        If Not dicoD1.Exists(clé) Then
            dicoD1.Add clé, 1
        Else
            dicoD1(clé) = dicoD1(clé) + 1
        End If
    Next i
    
    fin = .Range("B" & .Rows.Count).End(xlUp).Row
    For i = 2 To fin
        clé = .Range("B" & i)
        If Not dicoD2.Exists(clé) Then
            dicoD2.Add clé, 1
        Else
            dicoD2(clé) = dicoD2(clé) + 1
        End If
    Next i
    For Each clé In dicoD1.Keys
        If dicoD2.Exists(clé) Then
            If dicoD1(clé) <> dicoD2(clé) Then
                If dicoD1(clé) > dicoD2(clé) Then
                    .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(dicoD1(clé) - dicoD2(clé)) = clé
                Else
                    .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(dicoD2(clé) - dicoD1(clé)) = clé
                End If
            End If
        Else
            .Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(dicoD1(clé)) = clé
        
        End If
    Next clé
    For Each clé In dicoD2.Keys
        If dicoD1.Exists(clé) Then
            If dicoD1(clé) <> dicoD2(clé) Then
                If dicoD1(clé) > dicoD2(clé) Then
                    '.Range("F" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(dicoD1(clé) - dicoD2(clé)) = clé 'déjà traité dans la boucle précédente
                Else
                    .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(dicoD2(clé) - dicoD1(clé)) = clé
                End If
            End If
        Else
            .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(dicoD2(clé)) = clé
        
        End If
    Next clé
End With

End Sub
 

job75

XLDnaute Barbatruc
Bonjour Faroyo, vgendron, Roblochon,

Voyez le fichier joint et cette macro :
VB:
Sub Comparer()
Dim d As Object, P As Range, Q As Range, c As Range
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set P = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    Set Q = .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
    For Each c In P
        d(c.Value) = d(c.Value) + 1
        c = c & "|" & d(c.Value) 'ajoute la fréquence cumulée
    Next
    d.RemoveAll 'RAZ
    For Each c In Q
        d(c.Value) = d(c.Value) + 1
        c = c & "|" & d(c.Value) 'ajoute la fréquence cumulée
    Next
    Q.Copy P(P.Count + 1)
    With P(P.Count + 1).Resize(Q.Count)
        .Interior.ColorIndex = 6 'cellules ajoutées en jaune
        .EntireColumn.RemoveDuplicates 1, Header:=xlYes 'supprime les doublons
    End With
    P.Copy Q(Q.Count + 1)
    With Q(Q.Count + 1).Resize(P.Count)
        .Interior.ColorIndex = 6 'cellules ajoutées en jaune
        .EntireColumn.RemoveDuplicates 1, Header:=xlYes 'supprime les doublons
    End With
    Union(P, Q).EntireColumn.Replace "|*", "", xlPart 'RAZ
    .Rows.AutoFit 'ajuste les hauteurs'
End With
End Sub
Les cellules ajoutées dans chaque colonne sont en jaune en bas du tableau.

A+
 

Pièces jointes

  • test(1).xlsm
    22.2 KB · Affichages: 5

Discussions similaires

Statistiques des forums

Discussions
315 095
Messages
2 116 170
Membres
112 676
dernier inscrit
little_b