Doublons coloriés

Je voudrais en VBA sélectionner une plage de cellules, vérifier si chaque cellule ne trouve pas son double dans la selection et si oui, lui affecter un format différent.

Une variation sur la particularité des collections de déclencher une erreur lorsqu'on tente de leur ajouter un membre qui a déjà le même nom de clé. En prenant comme clé la valeur "texte" des cellules parcourues, une erreur signe l'apparition d'un doublon. La cellule qui a déclenché l'erreur est coloriée en vert. A la fin du traitement, les doublons apparaissent en vert et les cellules doublonnées ou uniques apparaissent en jaune :

sub DoublonOrNotDoublon()
 Dim Collec As New Collection, Cell As Range, Plage As Range
 
 On Error Resume Next
 Set Plage = Application.InputBox("Plage à examiner", Type:=8)
 If IsEmpty(Plage) Then exit sub
 
 For Each Cell In Plage
  If Cell.Value <> "" Then
   Collec.Add Cell.Value, CStr(Cell.Value)
   If Err <> 0 Then
    Err.Clear
    Cell.Interior.ColorIndex = 43
   Else
    Cell.Interior.ColorIndex = 6
   End If
  End If
 Next Cell
 end sub

Attention : cette macro te signale la première valeur identifiée comme doublon.
Maintenant s'il y en a plusieurs identiques et que tu veux toutes les marquer : Utilises plutôt la macro ci dessous. Mais la double boucle peut rendre l'exécution longuette selon la taille de la plage à examiner et la puissance de ta machine ...

sub MarqueLesDoublons()
 Dim Plage As Range, i&, Cell As Range, Rng As Range
 
 On Error Resume Next
 Set Plage = Application.InputBox("Plage à examiner", Type:=8)
 If IsEmpty(Plage) Then exit sub
 
 Application.ScreenUpdating = False
 
 For Each Cell In Plage
  For i = 1 To Plage.Count
   Set Rng = Cell.Offset(i)
   If Rng <> "" And Rng = Cell Then
    Cell.Interior.ColorIndex = 43
    Rng.Interior.ColorIndex = 43
    Exit For
   End If
  Next i
 Next Cell
 
 end sub

Auteur :

Mots clefs associés à cette page : , ,