Microsoft 365 Copie doublons

=SIERREUR(INDEX(Liste;EQUIV(0;NB.SI(C3:$C$3;Liste)+SI(NB.SI(Liste;Liste)>1;0;1);0));"")
( à valider en matriciel par Maj+Ctrl+Entrée )
et
=SI(NB.SI(Liste;C4)=0;"";NB.SI(Liste;C4))

Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, d As Object, i&, v, e, n&, resu(), a, b
tablo = Range("A1:B" & Cells.SpecialCells(xlCellTypeLastCell).Row) 'matrice, plus rapidee, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
    v = tablo(i, 1)
    If v <> "" Then d(v) = d(v) + 1
Next i
For Each e In d.keys
    If d(e) = 1 Then d.Remove e
Next e
n = d.Count
'---transposition---
If n Then
    ReDim resu(1 To n, 1 To 2)
    a = d.keys: b = d.items
    For i = 1 To n
        resu(i, 1) = a(i - 1): resu(i, 2) = b(i - 1)
    Next
End If
'---restitution---
Application.EnableEvents = False
With [C4] '1ère cellule de destination
    If n Then .Resize(n, 2) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
Application.EnableEvents = True
End Sub

Sub Test_mapomme()
Dim der&, t, i0&, i&, debut
   debut = Timer
   Application.ScreenUpdating = False
   With Sheets("Feuil1")
      ' préparation
      If FilterMode Then .ShowAllData
      der = .Cells(Rows.Count, "a").End(xlUp).Row
      .Range("c2:d2").Resize(Rows.Count - 1).Clear
      ' copie de la source vers colonne C puis tri de la colonne C
      .Range("a2:a" & der).Copy Range("c2")
      .Range("c1").Resize(der).Sort Key1:=[c1], order1:=xlAscending, Header:=xlYes
      der = .Cells(Rows.Count, "c").End(xlUp).Row
      ' lecture des colonne C à D dans un tableau
      t = .Range("c1").Resize(der + 1, 2)
      ' parcours du tableau t pour compter les occurences
      i0 = 2: t(i0, 2) = 1
      For i = 3 To UBound(t)
         If t(i, 1) = t(i0, 1) Then
            t(i0, 2) = t(i0, 2) + 1
         Else
            i0 = i
            t(i0, 2) = 1
         End If
      Next i
      ' parcours du tableau t pour regrouper les doublons dans le haut du tableau
      i0 = 1
      For i = 2 To UBound(t) - 1
         If t(i, 2) > 1 Then i0 = i0 + 1: t(i0, 1) = t(i, 1): t(i0, 2) = t(i, 2)
      Next i
      ' affichage du résultat
      .Range("c2:d2").Resize(Rows.Count - 1).Clear
      If i0 > 1 Then .Range("c1:d1").Resize(i0, 2) = t
   End With
   MsgBox Format(Timer - debut, "0.001\ sec.")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
' Code déja dans Worksheet_Change
Dim i&
Set Target = Intersect(Target, [V:V], UsedRange)
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next
With Feuil3 'CodeName à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    For Each Target In Target 'si entrées/effacements multiples
        If Target.Row > 1 Then
            If LCase(Target) = "t" Then
                i = 0
                i = Application.Match(Target(1, 0), .Columns(1), 0)
                If i = 0 Then i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1: .Cells(i, 1) = Target(1, -20)
                'Hyperlinks.Add Target(1, 2), "", .Name & "!" & .Cells(i, 1).Address(0, 0), TextToDisplay:="OA"
            ElseIf Target = "" Then
                Target(1, 2).Clear 'RAZ
                .Rows(Application.Match(Target(1, -19), .Columns(1), 0)).Delete
            End If
        End If
    Next
End With
[V:V].HorizontalAlignment = xlCenter 'centrage
    Application.EnableEvents = True 'réactive les évènements
    
' Code pour doublons
Dim tablo, d As Object, i&, v, e, n&, resu(), a, b
tablo = Range("A1:B" & Cells.SpecialCells(xlCellTypeLastCell).Row) 'matrice, plus rapidee, au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
    v = tablo(i, 1)
    If v <> "" Then d(v) = d(v) + 1
Next i
For Each e In d.keys
    If d(e) = 1 Then d.Remove e
Next e
n = d.Count
'---transposition---
If n Then
    ReDim resu(1 To n, 1 To 2)
    a = d.keys: b = d.items
    For i = 1 To n
        resu(i, 1) = a(i - 1): resu(i, 2) = b(i - 1)
    Next
End If
'---restitution---
Application.EnableEvents = False
With [C4] '1ère cellule de destination
    If n Then .Resize(n, 2) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
End With
Application.EnableEvents = True
End Sub