Suppression du contenu d'une cellule s'il y'a doublons

Bonjour,

j'écris ce nouveau post car je suis en galère depuis 2/3 jours sur un mini programme. Je vous explique le plus clairement possible :

j'ai deux listes de valeurs comme ceci:

Et je souhaite pouvoir faire une macro qui me supprime automatiquement les doublons lorsqu'il y'a la même valeurs dans les colonnes (ici le A 8) mais sans me supprimer pour autant la ligne, juste effacer ce qu'il y'a dans la cellule.

Ici, nous sommes d'accord qu'il y'a très peu d'intérêt vu le peu de lignes et le peu de doublons mais je travaille sur des fichiers avec énormément de valeurs, c'est pourquoi je cherche à automatiser au plus ce système.

Mon véritable problème est que j'arrive à supprimer les doublons mais cela me supprime la ligne entière, or moi j'aimerais garder la ligne pour ne pas créer de décalage.

Merci d'avance.

Cordialement,

Bonjour,

Il faut utiliser "ClearContents" au lieu de "Delete"

@+

Bonjour,

merci pour votre réponse cependant j'utilisais l'option .RemoveDuplicates que je trouve un peu brutal, et lorsque je tente de créer une boucle avec .ClearContents elle tourne sans s'arrêter et fait crash mon Excel...

Re,

Peut-on avoir le fichier ou le code SVP

@+

Alors, j'ai ce code la :

  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range("H1", [H65000].End(xlUp))
     d.Item(c.Value & c.Offset(, 1)) = d.Item(c.Value & c.Offset(, 1)) + 1
     d2.Item(c.Value & c.Offset(, 1)) = d2.Item(c.Value & c.Offset(, 1)) & CStr(c.Row) & "-"
  Next c
  For Each c In Range("H1", [H65000].End(xlUp))
    If d.Item(c.Value & c.Offset(, 1)) > 1 Then
       c.Resize(, 2).ClearContents
    End If
  Next c

Qui marche mais me supprime tous les doublons sans m'en garder un seul ce qui est un peu embêtant...

J'ai l'impression de m'en rapprocher de plus en plus mais sans vraiment avoir pile ce que je veux

Re,

Une procédure toute simple, pour moi pas besoin de passer par un dictionnaire

Sub SupDoublon()
  Dim dLig As Long, Lig As Long
  dLig = Range("H" & Rows.Count).End(xlUp).Row
  For Lig = 1 To dLig
    If Application.WorksheetFunction.CountIfs(Range("H1:H" & Lig), Range("H" & Lig), Range("I1:I" & Lig), Range("I" & Lig)) > 1 Then
       Range("H" & Lig).Resize(, 2).ClearContents
    End If
  Next Lig
End Sub

@+