XL 2019 Suppression automatique de cellules

Sub Liste_Col3()
Dim d As Object, tablo, j%, i&, x$, a, b, n&
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = [B1].CurrentRegion.Columns(1).Resize(, 2) 'matrice, plus rapide
For j = 1 To 2
    For i = 2 To UBound(tablo)
        x = tablo(i, j)
        If x <> "" Then d(x) = d(x) + 1 'comptage
Next i, j
'---tableau des résultats---
If d.Count Then
    ReDim resu(1 To d.Count, 1 To 1)
    a = d.keys: b = d.items
    For i = 0 To UBound(a)
        If b(i) < 2 Then n = n + 1: resu(n, 1) = a(i)
    Next i
End If
'---restitution---
With ActiveSheet 'à adapter éventuellement
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[D2] '1ère cellule de destination
        If n Then .Resize(n) = resu
        .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub