Sub extract()
Dim Uniques1 As Object, Uniques2 As Object, Cel As Range
Set Uniques1 = CreateObject("Scripting.Dictionary")
Set Uniques2 = CreateObject("Scripting.Dictionary")
With Sheets("F1")
For Each Cel In .Range("A1:A" & .[A65000].End(xlUp).Row)
If Not Uniques1.Exists(Cel) Then Uniques1.Add Cel, Cel
Next Cel
End With
With Sheets("F2")
For Each Cel In .Range("A1:A" & .[A65000].End(xlUp).Row)
If Not Uniques2.Exists(Cel) Then Uniques2.Add Cel, Cel
Next Cel
End With
For Each it2 In Uniques2.items
For Each it1 In Uniques1.items
If Left(it1, 28) = Left(it2, 28) Then Uniques2.Remove (it2): Exit For
Next it1
Next it2
With Sheets("F3")
.Columns(2).ClearContents
.[B1].Resize(Uniques2.Count, 1).Value = Application.Transpose(Uniques2.items)
End With
End Sub