Macro Doublons et valeurs uniques

O

océanne

XLDnaute Occasionnel
Bonjour le Forum,

Je m'interroge sur la faisabilité d'une petite macro, qui me permettrait à partir de valeurs contenues dans les deux premiers onglets (même format pour les tableaux dans les feuilles 1 et 2) de produire sur un troisieme onglet les doublons, puis sur un quatrieme les valeurs uniques.

J'ai renseigné dans le classeur en piece jointe un exemple et une zone de texte dans les feuilles "doublons" et "valeurs uniques" pour préciser mon besoin.

J'ai bien cherché tout d'abord dans vos nombreux messages, mais rien ne coincide vraiment avec ce que je recherche. Merci d'avance à celui ou celle qui pourra me donner un coup de main.

Deux bises

O.
 

Pièces jointes

  • Doublons et valeurs uniques.zip
    8.3 KB · Affichages: 43
  • Doublons et valeurs uniques.zip
    8.3 KB · Affichages: 52
  • Doublons et valeurs uniques.zip
    8.3 KB · Affichages: 45
Trier par date Trier par votes
suistrop

suistrop

XLDnaute Impliqué
Re : Macro Doublons et valeurs uniques

salut,

Si on un dans le tableau 1 : 0001 Boss 2
et dans le tableau 2 0001 Biz 2

doublons ou pas??

EN gros c est quoi qui définit un doublon les 3 colonne, les 2 premieres? la premiere? la seconde??


Have Fun !!

Et puis en adaptant 1 macro sauce béarnaise sur les doublons tu peux t en sortir !!!
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Macro Doublons et valeurs uniques

Bonsoir à tous,
Je vous propose une solution en VBA.
La procédure
Code: 
Sub commun()
Dim s1 As String, s2 As String, s4 As String, i As Long, j As Long, l As Long, v
Dim Ts1(), Ts2(), Sc()
    Application.ScreenUpdating = False
    s1 = "Tablo 1"
    s2 = "Tablo 2"
    s4 = "Doublons"
    With Sheets(s1): Ts1 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).Value: End With
    With Sheets(s2): Ts2 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).Value: End With
    ReDim Preserve Ts1(1 To UBound(Ts1, 1), 1 To 4)
    ReDim Preserve Ts2(1 To UBound(Ts2, 1), 1 To 4)
    For i = 2 To UBound(Ts1, 1)
        Ts1(i, 4) = Ts1(i, 1) & "#" & Ts1(i, 2) & "#" & Ts1(i, 3)
    Next i
    For i = 2 To UBound(Ts2, 1)
        Ts2(i, 4) = Ts2(i, 1) & "#" & Ts2(i, 2) & "#" & Ts2(i, 3)
    Next i
    l = 1
    ReDim Sc(1 To 3, 1 To l)
    Sc(1, l) = Ts1(1, 1): Sc(2, l) = Ts1(1, 2): Sc(3, l) = Ts1(1, 3)
    For i = 2 To UBound(Ts1, 1)
        v = Ts1(i, 4)
        For j = 1 To UBound(Ts2, 1)
            If Ts2(j, 4) = v Then Exit For
        Next j
        If j <= UBound(Ts2, 1) Then
            l = l + 1
            ReDim Preserve Sc(1 To 3, 1 To l)
            Sc(1, l) = Ts1(i, 1): Sc(2, l) = Ts1(i, 2): Sc(3, l) = Ts1(i, 3)
        End If
    Next i
    With Sheets(s4)
        .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).ClearContents
        .Range(Cells(1, 1), Cells(l, 3)).Value = Application.Transpose(Sc)
    End With
    Application.ScreenUpdating = True
End Sub
extrait les doublons des feuilles Tablo 1 et Tablo 1 pour les placer dans la feuille Doublons.
Celle-ci
Code: 
Sub unique()
Dim s1 As String, s2 As String, s3 As String, i As Long, j As Long, k As Long, v
Dim Ts1(), Ts2(), Su()
    Application.ScreenUpdating = False
    s1 = "Tablo 1"
    s2 = "Tablo 2"
    s3 = "Valeurs uniques"
    With Sheets(s1): Ts1 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).Value: End With
    With Sheets(s2): Ts2 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).Value: End With
    ReDim Preserve Ts1(1 To UBound(Ts1, 1), 1 To 4)
    ReDim Preserve Ts2(1 To UBound(Ts2, 1), 1 To 4)
    For i = 2 To UBound(Ts1, 1)
        Ts1(i, 4) = Ts1(i, 1) & "#" & Ts1(i, 2) & "#" & Ts1(i, 3)
    Next i
    For i = 2 To UBound(Ts2, 1)
        Ts2(i, 4) = Ts2(i, 1) & "#" & Ts2(i, 2) & "#" & Ts2(i, 3)
    Next i
    k = 1
    ReDim Su(1 To 4, 1 To k)
    Su(1, k) = Ts1(1, 1): Su(2, k) = Ts1(1, 2): Su(3, k) = Ts1(1, 3): Su(4, k) = "Provenance"
    For i = 2 To UBound(Ts1, 1)
        v = Ts1(i, 4)
        If Not IsEmpty(v) Then
            For j = 1 To UBound(Ts2, 1)
                If Ts2(j, 4) = v Then Exit For
            Next j
            If j > UBound(Ts2, 1) Then
                k = k + 1
                ReDim Preserve Su(1 To 4, 1 To k)
                Su(1, k) = Ts1(i, 1): Su(2, k) = Ts1(i, 2): Su(3, k) = Ts1(i, 3): Su(4, k) = s1
            Else
                Ts2(j, 4) = Empty
            End If
        End If
    Next i
    For i = 2 To UBound(Ts2, 1)
        If Not IsEmpty(Ts2(i, 4)) Then
            k = k + 1
            ReDim Preserve Su(1 To 4, 1 To k)
            Su(1, k) = Ts2(i, 1): Su(2, k) = Ts2(i, 2): Su(3, k) = Ts2(i, 3): Su(4, k) = s2
        End If
    Next i
    With Sheets(s3)
        .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 4)).ClearContents
        .Range(.Cells(1, 1), .Cells(k, 4)).Value = Application.Transpose(Su)
    End With
    Application.ScreenUpdating = True
End Sub
extrait les enregistrements uniques des feuilles Tablo 1 et Tablo 1 pour les placer dans la feuille Valeurs uniques et préciser leur origine.
Celle-là
Code: 
Sub commun_unique()
Dim s1 As String, s2 As String, s3 As String, s4 As String
Dim i As Long, j As Long, k As Long, l As Long, v
Dim Ts1(), Ts2(), Su(), Sd()
    Application.ScreenUpdating = False
    s1 = "Tablo 1"
    s2 = "Tablo 2"
    s3 = "Valeurs uniques"
    s4 = "Doublons"
    With Sheets(s1): Ts1 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).Value: End With
    With Sheets(s2): Ts2 = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).Value: End With
    ReDim Preserve Ts1(1 To UBound(Ts1, 1), 1 To 4)
    ReDim Preserve Ts2(1 To UBound(Ts2, 1), 1 To 4)
    For i = 2 To UBound(Ts1, 1)
        Ts1(i, 4) = Ts1(i, 1) & "#" & Ts1(i, 2) & "#" & Ts1(i, 3)
    Next i
    For i = 2 To UBound(Ts2, 1)
        Ts2(i, 4) = Ts2(i, 1) & "#" & Ts2(i, 2) & "#" & Ts2(i, 3)
    Next i
    k = 1
    ReDim Su(1 To 4, 1 To k)
    Su(1, k) = Ts1(1, 1): Su(2, k) = Ts1(1, 2): Su(3, k) = Ts1(1, 3): Su(4, k) = "Provenance"
    l = 1
    ReDim Sc(1 To 3, 1 To l)
    Sc(1, l) = Ts1(1, 1): Sc(2, l) = Ts1(1, 2): Sc(3, l) = Ts1(1, 3)
    For i = 2 To UBound(Ts1, 1)
        v = Ts1(i, 4)
        If Not IsEmpty(v) Then
            For j = 1 To UBound(Ts2, 1)
                If Ts2(j, 4) = v Then Exit For
            Next j
            If j > UBound(Ts2, 1) Then
                k = k + 1
                ReDim Preserve Su(1 To 4, 1 To k)
                Su(1, k) = Ts1(i, 1): Su(2, k) = Ts1(i, 2): Su(3, k) = Ts1(i, 3): Su(4, k) = s1
            Else
                l = l + 1
                ReDim Preserve Sc(1 To 3, 1 To l)
                Sc(1, l) = Ts1(i, 1): Sc(2, l) = Ts1(i, 2): Sc(3, l) = Ts1(i, 3)
                Ts2(j, 4) = Empty
            End If
        End If
    Next i
    For i = 2 To UBound(Ts2, 1)
        If Not IsEmpty(Ts2(i, 4)) Then
            k = k + 1
            ReDim Preserve Su(1 To 4, 1 To k)
            Su(1, k) = Ts2(i, 1): Su(2, k) = Ts2(i, 2): Su(3, k) = Ts2(i, 3): Su(4, k) = s2
        End If
    Next i
    With Sheets(s3)
        .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 4)).ClearContents
        .Range(.Cells(1, 1), .Cells(k, 4)).Value = Application.Transpose(Su)
    End With
    With Sheets(s4)
        .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3)).ClearContents
        .Range(.Cells(1, 1), .Cells(l, 3)).Value = Application.Transpose(Sc)
    End With
    Application.ScreenUpdating = True
End Sub
réalise simultanément les deux opérations.
Voilà. Bonne nuit !​
ROGER2327
 
Vote positif 0 Vote négatif
skoobi

skoobi

XLDnaute Barbatruc
Re : Macro Doublons et valeurs uniques

Bonjour tout le monde,

comme c'est fait, une autre proposition en utilisant l'objet Dictionary:

Code: 
Sub compare()
Dim Tab1 As Worksheet, Tab2 As Worksheet, Lig As Long, Temp As String, i As Long, j As Long
Dim Tablo1(), Tablo2(), Unique(), Doublon(), k As Long
  Set mondico = CreateObject("Scripting.Dictionary")
  Set Tab1 = Sheets("Tablo 1"): Set Tab2 = Sheets("Tablo 2")
  With Tab1
    Tablo1 = .Range("A2", .[C65536].End(xlUp)).Value
    For k = LBound(Tablo1, 1) To UBound(Tablo1, 1)
      Temp = Tablo1(k, 1) & Tablo1(k, 2) & Tablo1(k, 3)
      mondico.Add Temp, 1
    Next
  End With
  With Tab2
    Tablo2 = .Range("A2", .[C65536].End(xlUp)).Value
    For k = LBound(Tablo2, 1) To UBound(Tablo2, 1)
      Temp = Tablo2(k, 1) & Tablo2(k, 2) & Tablo2(k, 3)
      If Not mondico.Exists(Temp) Then
        mondico.Add Temp, 1
      Else
        mondico(Temp) = 2
      End If
    Next
  End With
  i = 0: j = 0
  For k = LBound(Tablo1, 1) To UBound(Tablo1, 1)
    Temp = Tablo1(k, 1) & Tablo1(k, 2) & Tablo1(k, 3)
    If mondico(Temp) = 1 Then
      i = i + 1
      ReDim Preserve Unique(1 To 4, 1 To i)
      Unique(1, i) = Tablo1(k, 1): Unique(2, i) = Tablo1(k, 2): Unique(3, i) = Tablo1(k, 3)
      Unique(4, i) = Tab1.Name
    ElseIf mondico(Temp) > 1 Then
      j = j + 1
      ReDim Preserve Doublon(1 To 3, 1 To j)
      Doublon(1, j) = Tablo1(k, 1): Doublon(2, j) = Tablo1(k, 2): Doublon(3, j) = Tablo1(k, 3)
    End If
  Next
  For k = LBound(Tablo2, 1) To UBound(Tablo2, 1)
    Temp = Tablo2(k, 1) & Tablo2(k, 2) & Tablo2(k, 3)
    If mondico(Temp) = 1 Then
      i = i + 1
      ReDim Preserve Unique(1 To 4, 1 To i)
      Unique(1, i) = Tablo2(k, 1): Unique(2, i) = Tablo2(k, 2): Unique(3, i) = Tablo2(k, 3)
      Unique(4, i) = Tab2.Name
    End If
  Next
  With Sheets("Doublons")
    .Range("A2", .Range("C" & UBound(Doublon, 2) + 1)).Value = Application.Transpose(Doublon)
  End With
  With Sheets("Valeurs uniques")
    .Range("A2", .Range("D" & UBound(Unique, 2) + 1)).Value = Application.Transpose(Unique)
  End With
End Sub
 
Vote positif 0 Vote négatif
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Macro Doublons et valeurs uniques

Bonjour,

Code: 
Sub Doublons()
    Sheets("Tablo 2").Range("A1:C1000").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("F1:F2"), CopyToRange:=Range("A1:C1"), Unique:=False
End Sub
Sub T1_T2()
    Sheets("Tablo 1").Range("A1:C1000").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("F1:F2"), CopyToRange:=Range("A1:C1"), Unique:=False
End Sub
Sub T2_T1()
    Sheets("Tablo 2").Range("A1:C1000").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("F1:F2"), CopyToRange:=Range("A1:C1"), Unique:=False
End Sub


JB
 

Pièces jointes

  • Doublons et valeurs uniques.zip
    45.4 KB · Affichages: 55
  • Doublons et valeurs uniques.zip
    45.4 KB · Affichages: 50
  • Doublons et valeurs uniques.zip
    45.4 KB · Affichages: 56
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Macro Doublons et valeurs uniques

Bonjour à tous
Sur un sujet rebattu, océanne a de la chance : trois solutions qui ne font pas la même chose.
La solution de BOISGONTIER, concise et élégante comme d'habitude, discrimine les enregistrements sur leur premier champ. Elle s'éloigne un peu de la demande initiale en ajoutant une feuille, mais il n'est pas très difficile d'y remédier.
skoobi et moi cherchons à comparer tous les champs de chacun des enregistrements.
Cette différence d'approche résulte du manque de précision de la demande initiale immédiatement remarquée par suistrop.
_
Les deux approches sont complémentaires.
Sur des données "propres", i.e. réputées sans erreur de saisie, et compte tenu de l'intitulé de la première colonne (Matricule), la solution de BOISGONTIER s'impose.
Les autres propositions sont plus adaptées à la détection d'éventuelles erreurs de saisie. Par exemple Jaques et Jacques.​
Deux remarques toutefois sur la proposition de skoobi :
  1. La simple concaténation des champs sans séparateur confond les enregistrements :

    champ 1_____champ 2
    _____________________________
    _
    _0007_______0Toto
    00070_______Toto
    _
  2. La comparaison ne prend pas en compte les lignes après le dernier champ Quantité non vide (et le cas peut se présenter selon la demande d'océanne).
Il ne reste plus à océanne qu'à préciser sa demande...
​
Bonne journée à tous,
ROGER2327
 
Vote positif 0 Vote négatif

Discussions similaires

Bernard_XLD
  • Résolu(e)
Microsoft 365 Reporter automatiquement le nombre de valeurs uniques d'un tableau structuré filtré par plusieurs segments.
Réponses
3
Affichages
414
chris
chris
oguruma
POWERQUERY :: DEDOUBLONNER les doublons
Réponses
0
Affichages
175
oguruma
oguruma
A
  • Résolu(e)
XL 2021 suppression de doublons
2 3
Réponses
31
Affichages
1 K
auloin
A
E
  • Question
XL 2016 Comment créer une routine pour coller des valeurs dans différents classeurs fermés sous condition.
Réponses
7
Affichages
401
Eosine
E
Z
  • Question
Microsoft 365 Validation de données et saisie partielle
Réponses
3
Affichages
188
Dranreb
Dranreb
P
  • Question
XL 2019 doublons et lignes vides
Réponses
0
Affichages
366
pibes
P
L
  • Question
Power Query groupés deux tableaux qui existent sur la même feuille et ajout d'information supplémentaire
Réponses
7
Affichages
667
Aurelili
A
L
  • Résolu(e)
XL 2016 Problème liaison USF vers tableau et inversément
Réponses
1
Affichages
277
Ludo G
L
E
  • Résolu(e)
XL 2016 vérifier entre deux fichiers que les valeurs d'une colonne correspondent en vba
Réponses
8
Affichages
501
Excellerateur
E
C
  • Question
Microsoft 365 Recherche valeurs dans une colonne / doublons
Réponses
5
Affichages
843
Casim
C

Membres actuellement en ligne

13 membres et 149 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 486
Messages
2 088 820
Membres
103 971
dernier inscrit
abdazee