XL 2010 Mettre à jour ma liste sous condition

Sub MajListe()
Dim D1, D2, D3, W1 As Worksheet, W2 As Worksheet, W3 As Worksheet
Dim T1, T2, T3, i As Long, Clé
Set D1 = CreateObject("Scripting.Dictionary")
Set D2 = CreateObject("Scripting.Dictionary")
Set D3 = CreateObject("Scripting.Dictionary")
Set W1 = Worksheets("Liste")
Set W2 = Worksheets("Dispo")
Set W3 = Worksheets("Parametre")
T1 = W1.Range("A4:A" & W1.Range("A" & Rows.Count).End(xlUp).Row)
T2 = W2.Range("B3:B" & W2.Range("B" & Rows.Count).End(xlUp).Row)
T3 = W3.Range("J2:J" & W3.Range("J" & Rows.Count).End(xlUp).Row)

For i = LBound(T1) To UBound(T1)
    D1(T1(i, 1)) = ""
Next
For i = LBound(T2) To UBound(T2)
    D2(T2(i, 1)) = ""
Next
For i = LBound(T3) To UBound(T3)
    D3(T3(i, 1)) = ""
Next
For Each Clé In D1.keys
    If Not D2.Exists(Clé) Then D1.Remove (Clé)
Next

For Each Clé In D2.keys
    If D3.Exists(Clé) Then D1(Clé) = ""
Next
W1.Range("A4:A" & W1.Range("A" & Rows.Count).End(xlUp).Row).ClearContents
W1.Range("A4").Resize(D1.Count, 1) = Application.Transpose(D1.keys)
End Sub

W1.Range("A4:A" & W1.Range("A16" & Rows.Count).End(xlUp).Row).ClearContents