extraire les cellules uniques de 2 listes

Sub ExtraitDoublons()
Dim Plg As Variant, Item As Variant, SansDoublon As Variant
Dim Plg2 As Variant, Col2 As Collection, Nouveau As Variant [COLOR="SeaGreen"]'*[/COLOR]
Dim Col As Collection
Dim I As Integer 'Long
   Application.ScreenUpdating = False
   With Sheets("Prospects")
      Plg = .Range("B2:B" & .Range("B65536").End(xlUp).Row)
   End With
   Set Col = New Collection
   For I = 1 To UBound(Plg, 1)
      On Error Resume Next
      Col.Add Plg(I, 1), CStr(Plg(I, 1))
      On Error GoTo 0
   Next I
   ReDim SansDoublon(1 To Col.Count, 1 To 1)
   I = 0
   For Each Item In Col
      I = I + 1
      SansDoublon(I, 1) = Item
   Next Item
   With Sheets("Prospects") [COLOR="SeaGreen"]'*[/COLOR]
      Plg2 = .Range("F2:F" & .Range("F65536").End(xlUp).Row) [COLOR="SeaGreen"]'*[/COLOR]
   End With [COLOR="SeaGreen"]'*[/COLOR]
   Set Col2 = New Collection [COLOR="SeaGreen"]'*[/COLOR]
   For I = 1 To UBound(Plg, 1) [COLOR="SeaGreen"]'*[/COLOR]
      On Error Resume Next [COLOR="SeaGreen"]'*[/COLOR]
      Col2.Add Plg2(I, 1), CStr(Plg2(I, 1)) [COLOR="SeaGreen"]'*[/COLOR]
      On Error GoTo 0 [COLOR="SeaGreen"]'*[/COLOR]
   Next I [COLOR="SeaGreen"]'*[/COLOR]
   For Each Item In Col [COLOR="SeaGreen"]'*[/COLOR]
      On Error Resume Next [COLOR="SeaGreen"]'*[/COLOR]
      Col2.Remove Item  [COLOR="SeaGreen"]'*[/COLOR]
      On Error GoTo 0 [COLOR="SeaGreen"]'*[/COLOR]
   Next Item [COLOR="SeaGreen"]'*[/COLOR]
   Set Col = Nothing
   ReDim Nouveau(1 To Col2.Count, 1 To 1) [COLOR="SeaGreen"]'*[/COLOR]
   I = 0 [COLOR="SeaGreen"]'*[/COLOR]
   For Each Item In Col2 [COLOR="SeaGreen"]'*[/COLOR]
      If Not IsEmpty(Item) Then I = I + 1: Nouveau(I, 1) = Item [COLOR="SeaGreen"]'*[/COLOR]
   Next Item [COLOR="SeaGreen"]'*[/COLOR]
   Set Col2 = Nothing [COLOR="SeaGreen"]'*[/COLOR]
   With Sheets("Prospects")
      .Range("D2").Resize(UBound(SansDoublon, 1), UBound(SansDoublon, 2)) = SansDoublon
   End With
   With Sheets("Prospects") [COLOR="SeaGreen"]'*[/COLOR]
      .Range("H2").Resize(UBound(Nouveau, 1), UBound(Nouveau, 2)) = Nouveau [COLOR="SeaGreen"]'*[/COLOR]
   End With [COLOR="SeaGreen"]'*[/COLOR]
   Application.ScreenUpdating = True
End Sub