Поиск дубликатов в двух массивах с последующим удалением их из виртуального массива

Dim lLastRow2
        lLastRow2 = Cells(Rows.Count, 2).End(xlUp).Row + 4
        Dim x, m
        For x = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        For m = lLastRow2 To Cells(Rows.Count, 2).End(xlUp).Row
        If Cells(x, 2) > 0 Then
        If Cells(m, 2) > 0 Then
            If Cells(x, 2) = Cells(m, 2) Then

Sub macro1()
Sheets("Лист1").Select
asd = Cells(Rows.Count, 2).End(xlUp).Row
For i = asd To 2 Step -1
If Cells(i, 2) = "" Then
If y = 0 Then y = i
d = i
End If
Next i
d = d - 1: y = y + 1
 
strSQL = "SELECT First(a8.f1) AS [First-f1], a8.f2, First(a8.f3) AS [First-f3], First(a8.f4) AS [First-f4], First(a8.f5) AS [First-f5], First(a8.f6) AS [First-f6]"
strSQL = strSQL & " FROM [Лист1$a2:f" & d & "] AS a8 RIGHT JOIN (SELECT a5.f2 FROM"
strSQL = strSQL & " (SELECT a3.f2, a3.f10, IIf(IsNull([a4].[F20]),0,[a4].[F20]) AS f30"
strSQL = strSQL & "  FROM"
strSQL = strSQL & " (SELECT a1.f2, Count(a1.f2) AS f10"
strSQL = strSQL & " FROM [Лист1$a2:f" & d & "] AS a1 GROUP BY a1.f2)  AS a3 LEFT JOIN"
strSQL = strSQL & " (SELECT a2.f2, Count(a2.f2) AS F20"
strSQL = strSQL & " FROM [Лист1$a" & y & ":f" & asd & "] AS a2"
strSQL = strSQL & " GROUP BY a2.f2)  AS a4 ON a3.f2 = a4.f2)  AS a5"
strSQL = strSQL & " WHERE ((([f10]-[f30])>0)))  AS a6 ON a8.f2 = a6.f2"
strSQL = strSQL & " GROUP BY a8.f2"
Dim objConnection As Object
Dim rs As Object
 
Set objConnection = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.Path & "/" & ActiveWorkbook.Name & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
rs.Open strSQL, objConnection, 3, 3
Sheets("Не дубликаты").Cells(2, 1).CopyFromRecordset rs
 
Set objConnection = Nothing
Set rs = Nothing
 
Rows("1:1").Select
Selection.Copy
Sheets("Не дубликаты").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("Лист1").Select
Columns("A:F").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Не дубликаты").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
    
End Sub

Option Explicit
 
Sub tt()
Dim a, b, i&, ii&, lr&, t$, col As New Collection
 
With Sheets(1)
    lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    a = .[a1].CurrentRegion.Columns(2).Value
    b = .Cells(lr, "A").CurrentRegion.Columns(2).Value
 
On Error Resume Next
For i = 1 To UBound(b)
    t = b(i, 1): col.Add t, t
Next
 
Err.Clear
For i = 1 To UBound(a)
    t = a(i, 1): col.Add t, t
    If Err = 0 Then
        ii = ii + 1: .Rows(i).Copy Sheets(2).Cells(ii, 1)
    Else
        Err.Clear
    End If
Next
 
End With
End Sub

Option Explicit
 
Sub tt()
Dim a, b, i&, ii&, lr&, t$, col As New Collection, tmp&
 
With Sheets(1)
    lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    a = .[a1].CurrentRegion.Columns(2).Value
    b = .Cells(lr, "A").CurrentRegion.Columns(2).Value
 
On Error Resume Next
For i = 1 To UBound(b)
    t = b(i, 1): col.Add 1, t
    If Err Then
    tmp = col(t)
    col.Remove (t)
    col.Add tmp + 1, t
    Err.Clear
    End If
Next
 
Err.Clear
For i = 1 To UBound(a)
    t = a(i, 1): col.Add t, t
    If Err = 0 Then
        ii = ii + 1: .Rows(i).Copy Sheets(2).Cells(ii, 1)
        col.Remove (t)
    Else
        tmp = col(t)
        col.Remove (t)
        If tmp > 1 Then col.Add tmp - 1, t
        Err.Clear
    End If
Next
 
End With
End Sub

Option Explicit
 
Sub tt()
Dim a, b, i&, ii&, lr&, t$, col As New Collection, tmp&
 
With Sheets(1) 'работаем с первым листом
    lr = .Cells(.Rows.Count, 2).End(xlUp).Row 'последняя строка
    a = .[a1].CurrentRegion.Columns(2).Value 'массив данных из верхней непрерывной части
    b = .Cells(lr, "A").CurrentRegion.Columns(2).Value 'массив из нижней
 
On Error Resume Next 'отключение ошибок
For i = 1 To UBound(b) 'цикл по нижнему массиву
    t = b(i, 1): col.Add 1, t 'попытка добавить в коллекцию номер в текстовом виде с счётчиком
    If Err Then ' если не добавилось, т.е. уже есть
    tmp = col(t) 'запоминаем значение счётчика
    col.Remove (t) 'удаляем из коллекции
    col.Add tmp + 1, t 'добавляем с увеличенным счётчиком
    Err.Clear 'сбрасываем ошибку
    End If
Next
 
Err.Clear 'сбрасываем ошибку, на всякий - по идее тут ошибки быть не должно
For i = 1 To UBound(a) 'цикл по верхнему массиву
    t = a(i, 1): col.Add t, t 'попытка добавить в коллекцию номер в текстовом виде
    If Err = 0 Then 'если нет ошибки, т.е. добавилось
        ii = ii + 1: .Rows(i).Copy Sheets(2).Cells(ii, 1) 'копируем строку на второй лист
        col.Remove (t) 'удаляем из коллекции только что добавленное
    Else 'если ошибка была, т.е не добавилось
        tmp = col(t) 'запоминаем значение счётчика
        col.Remove (t) 'удаляем из коллекции
        If tmp > 1 Then col.Add tmp - 1, t 'если счётчик >1 то добавляем с уменьшенным счётчиком
        Err.Clear 'сбрасываем ошибку
    End If
Next
 
End With
End Sub