Macro qui met en évidence les doublons

Option Explicit

Const lidat = 1
Const sep = "-"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim co As Long, li As Long, lifin As Long
Dim dico As Object, cle As String, valeur As Long, cles, valeurs
Dim nucle As Long, nbcles As Long, t, nt As Long, k As Long
Dim coul As Long
li = Target.Row
If Target.Cells(1, 1) = "" Or li <> lidat Then Range("A1").Select: Exit Sub
co = Target.Column
' enlever les couleurs
Columns(co).Interior.ColorIndex = xlNone
Columns(co + 1).Interior.ColorIndex = xlNone
lifin = Cells(Rows.Count, 2).End(xlUp).Row
' dictionairee nom,liste_adresses
Set dico = CreateObject("scripting.dictionary")
For li = lidat + 2 To lifin Step 2
  'cellule de gauche
  cle = Trim(Cells(li, co).Cells(1, 1).Value)
  If cle <> "" And Not IsDate(cle) Then
    If dico.exists(cle) Then
      dico(cle) = dico(cle) & sep & Cells(li, co).Address
    Else
      dico.Add cle, Cells(li, co).Address
    End If
  End If
  'cellule de droite (si pas date)
  If Not IsDate(Cells(li, co).Cells(1, 1).Value) Then
    cle = Trim(Cells(li, co + 1).Value)
    If cle <> "" Then
      If dico.exists(cle) Then
        dico(cle) = dico(cle) & sep & Cells(li, co + 1).Address
      Else
        dico.Add cle, Cells(li, co + 1).Address
      End If
    End If
  End If
Next li
cles = dico.keys
valeurs = dico.items
nbcles = dico.Count
coul = 3
' coloriage des doublons
For nucle = 0 To nbcles - 1
  t = Split(valeurs(nucle), sep)
  nt = UBound(t)
  If nt > 0 Then
    For k = 0 To UBound(t)
      Range(t(k)).Interior.ColorIndex = coul
    Next k
  coul = coul + 1
  End If
Next nucle
Cells(lidat, co + 2).Cells(1, 1).Select
End Sub

à mettre dans le module de la feuille à traiter

Clic-clic en ligne 1 sur une date pour lancer la macro

Cdlmnt