Sub ListDel()
Dim arrA(), arrB(), arr()
Dim I&, N&
With Worksheets("Лист1")
  arrA = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
  arrB = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
ReDim arr(1 To UBound(arrA), 1 To 1)
With CreateObject("Scripting.Dictionary")
  For I = LBound(arrB, 1) To UBound(arrB, 1)
    iTmp = .Item(arrB(I, 1))
  Next
  For I = LBound(arrA) To UBound(arrA)
    If Not .Exists(arrA(I, 1)) Then
      N = N + 1
      arr(N, 1) = arrA(I, 1)
    End If
  Next
End With
Application.ScreenUpdating = False
With Worksheets("Лист1")
  .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).ClearContents
  .Range("A1").Resize(N) = arr
End With
Application.ScreenUpdating = True
End Sub