VBA pour détecter les doublons d'une colonne

pepsi

XLDnaute Occasionnel
Bonjour le forum :)

j'ai récupéré un code qui permet de détecter les doublons d'une colonne
le problème c'est qu 'il considère le 0 comme un doublon, et j'aimerai éviter cela

comment puis je modifie le code?

merci d'avance
Code:
Sub Doublon()
 
    Dim Plage As Range
    Dim Cel As Range
 
    With Worksheets("Feuil1")
 
    'en colonne "A" à partir de A2
       Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
    End With
 
 
    'boucle la plage de la feuille "Compte" et cherche chaque valeur
   'en correspondance exacte dans la plage de la feuille "Source"
   For Each Cel In Plage
 
        If Application.CountIf(Plage, Cel.Value) > 1 Then
 
            MsgBox "Attention, la valeur '" & Cel.Value & "' est en doublon," _
                   & " veuillez éliminer manuellement le double situé en '" & Cel.Address(0, 0) _
                   & "' avant de pouvoir exporter les données !"
 
            Cel.Interior.ColorIndex = 3
 
        End If
 
    Next Cel
 
End Sub
 

pepsi

XLDnaute Occasionnel
Re : VBA pour détecter les doublons d'une colonne

Bonjour



Le plus simple serait d'utiliser une mise en forme conditionnelle, non ?

@ plus


tu m'as donné un piste effectivement

mais le code considère tous les cellules ayant une valeur nulle en doublon




Code:
 Columns("A:A").Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -52429
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
  
End Sub
 

pepsi

XLDnaute Occasionnel
Re : VBA pour détecter les doublons d'une colonne

Code:
Sub Doublon()
    Dim Plage As Range
    Dim Cel As Variant
 
Set Plage = Worksheets("Feuil1").Range("a2:a" & [a65000].End(xlUp).Row)
Set d = CreateObject("Scripting.Dictionary"): Set d2 = CreateObject("Scripting.Dictionary")

   For Each Cel In Plage
        If Cel.Value <> 0 And d.exists(Ucase(Cel.Value)) Then
            Cel.Interior.ColorIndex = 3: d2(Cel.Address) = Cel.Value
                Else: d(Ucase(Cel.Value)) = ""
        End If
    Next Cel
    
    For Each Cel In d2.Keys
        m = m & Chr(10) & d2(Cel) & " en " & Cel
    Next Cel
    
MsgBox "Les valeurs suivantes sont en doublons, les supprimer manuellement" & m, vbCritical
End Sub

Dis-moi si ça fonctionne.

On ne peut pas passer la première occurrence en rouge car elle n'est pas considérée comme un doublon, c'est pour ça ?
 

pepsi

XLDnaute Occasionnel
Re : VBA pour détecter les doublons d'une colonne






j'essaye d'adapter le code que tu as proposé, en essayer d'afficher un message signalant les doublons reperés.


voilà ma modification qui ne fonctionne pas...



Code:
Sub ColoriageDoublons()
  [A:A].Interior.ColorIndex = xlNone
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each C In Range("a2", [a65000].End(xlUp))
   If C.Value <> 0 Then
    mondico.Item(C.Value) = mondico.Item(C.Value) + 1
    End If
  Next C
  For Each C In Range("a2", [a65000].End(xlUp))
    If mondico.Item(C.Value) > 1 Then C.Interior.ColorIndex = 3
  Next C
 
    
    For Each C In Range("a2", [a65000].End(xlUp))
    If mondico.Item(C.Value).exist Then
     m = m & Chr(10) & mondico(C)
       
            End If
        
          Next C
    
MsgBox "Les valeurs suivantes sont en doublons, les supprimer manuellement" & m, vbCritical
    
    End
    
End Sub
 

laetitia90

XLDnaute Barbatruc
Re : VBA pour détecter les doublons d'une colonne

bonjour tous :):)
essai de changer

Code:
For Each C In Range("a2", [a65000].End(xlUp))
    If mondico.Item(C.Value).exist Then
     m = m & Chr(10) & mondico(C)
       
            End If
        
          Next C

par
Code:
  For Each C In Range("a2", [a65000].End(xlUp))
    If mondico.exists(C.Value) Then m = m & Chr(10) & mondico(C)
    Next C

comme cela c'est mieux

Code:
 For Each C In Range("a2", [a65000].End(xlUp))
    If mondico.exists(C.Value) Then m = m & Chr(10) & mondico.Item(C)
    Next C
 
Dernière édition:

pepsi

XLDnaute Occasionnel
Re : VBA pour détecter les doublons d'une colonne

Le message box ne me renvoie pas du tout les doublons...

Code:
Sub ColoriageDoublons()
  [A:A].Interior.ColorIndex = xlNone
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each C In Range("a2", [a65000].End(xlUp))
   If C.Value <> 0 Then
    mondico.Item(C.Value) = mondico.Item(C.Value) + 1
    End If
  Next C
  For Each C In Range("a2", [a65000].End(xlUp))
    If mondico.Item(C.Value) > 1 Then C.Interior.ColorIndex = 3
  Next C

For Each C In Range("a2", [a65000].End(xlUp))
    If mondico.exists(C.Value) Then m = m & Chr(10) & mondico.Item(C.Value)
    Next C

    
MsgBox "Les valeurs suivantes sont en doublons, les supprimer manuellement" & m, vbCritical
    
    End
    
End Sub
 

Si...

XLDnaute Barbatruc
Re : VBA pour détecter les doublons d'une colonne

salut

avec un second dico ?
Code:
Sub ColoriageDoublons()
  Dim D1, D2, P As Range, C As Range, a(), n As Long, L As String
  [A:A].Interior.ColorIndex = xlNone
  Set D1 = CreateObject("Scripting.Dictionary")
  Set P = Range("A2", [A65000].End(xlUp))
  For Each C In P
   If C.Value <> 0 Then D1.Item(C.Value) = D1.Item(C.Value) + 1
  Next
  Set D2 = CreateObject("Scripting.Dictionary")
  For Each C In P
    If D1.Item(C.Value) > 1 Then
      C.Interior.ColorIndex = 3
      If D2(C.Value) = "" Then D2(C.Value) = C
    End If
  Next
  a = D2.keys
  For n = 0 To UBound(a): L = L & a(n) & vbLf: Next
  MsgBox "Les valeurs suivantes sont en doublon :" & vbLf & L, 64, "Attention..."
End Sub
 

Discussions similaires

Réponses
2
Affichages
129
Réponses
1
Affichages
119
Réponses
0
Affichages
83

Statistiques des forums

Discussions
311 720
Messages
2 081 917
Membres
101 839
dernier inscrit
laurentEstrées