XL 2010 VBA Compare 2 listes et copier les nom suplementaire

Option Explicit
Sub Ajouter()
'
Dim Ws1, Ws2 As Worksheet
Dim a, b, c
Dim D1, D2
Dim Last As Long
Set Ws1 = Sheets("BDD1"): Set Ws2 = Sheets("Liste")
a = Ws2.Range("a2:a" & Ws2.[A65000].End(xlUp).Row)
Ws2.[D1].Value = "Tous"
Set D1 = CreateObject("Scripting.Dictionary")
For Each c In a
   If Not D1.exists(c) Then D1.Add c, c
Next c
b = Ws1.Range("a2:a" & Ws1.[A65000].End(xlUp).Row)
Set D2 = CreateObject("Scripting.Dictionary")
For Each c In b
   If Not D1.exists(c) Then D2.Add c, c
Next c
If D2.Count = 0 Then Exit Sub
Last = Ws2.[a5000].End(xlUp).Row + 1
Ws2.Range("a" & Last).Resize(D2.Count, 1) = Application.Transpose(D2.Items)
End Sub