Сравнение двух списков и вывод разницы между ними

Sub Поиск()
 
Dim i As Long
Dim j As Long
Dim y As Long
Dim p As Long
 
Dim List1Count As Long, List2Count As Long
List1Count = Sheet1.UsedRange.Rows.Count
List2Count = Sheet2.UsedRange.Rows.Count
 
y = 0 
p = 0
 
For i = 1 To List2Count 
p = 0
    For j = 1 To List1Count 
        
        If LCase(Sheet2.Cells(i, 1)) = LCase(Sheet1.Cells(j, 1)) And _
           LCase(Sheet2.Cells(i, 2)) = LCase(Sheet1.Cells(j, 2)) And _
           LCase(Sheet2.Cells(i, 3)) = LCase(Sheet1.Cells(j, 3)) And _
           LCase(Sheet2.Cells(i, 4)) = LCase(Sheet1.Cells(j, 4)) And _
           LCase(Sheet2.Cells(i, 3)) = LCase(Sheet1.Cells(j, 3)) Then
        y = y + 1
        
            Sheet3.Cells(y, 1) = Sheet2.Cells(i, 1)
            Sheet3.Cells(y, 2) = Sheet2.Cells(i, 2)
            Sheet3.Cells(y, 3) = Sheet2.Cells(i, 3)
            Sheet3.Cells(y, 4) = Sheet2.Cells(i, 4)
            Sheet3.Cells(y, 5) = Sheet2.Cells(i, 5)
            
         End If 
  Next j
  
Sheet3.Cells(1, 11) = CSng(i * 100 / List2Count)
DoEvents
Next i 
 
MsgBox "Список верен!"
End Sub

Sub compRanges(Rg1 As Range, Rg2 As Range)
Dim Dict As Scripting.Dictionary
Dim w    As Range
 
    Set Dict = New Dictionary
    
    '::: Грузим весь первый в словарь
    
    n& = 0
    
    For Each w In Rg1
        Dict.Add CStr(w.Value), n&
        n& = n& + 1
    Next
    
    '::: Проверяем второй
    
    For Each w In Rg2
        If Not Dict.Exists(CStr(w.Value)) Then Debug.Print "Нет в первом, есть во втором: "; w.Value
    Next
    
    Dict.RemoveAll
        
    '::: Грузим весь второй в словарь
    
    n& = 0
    
    For Each w In Rg2
        Dict.Add CStr(w.Value), n&
        n& = n& + 1
    Next
    
    '::: Проверяем первый
    
    For Each w In Rg1
        If Not Dict.Exists(CStr(w.Value)) Then Debug.Print "Нет во втором, есть в первом: "; w.Value
    Next
        
    Set Dict = Nothing
 
End Sub
 
Sub Test()
Dim Rg1 As Range
Dim Rg2 As Range
 
    Set Rg1 = Range("A1:A7")
    Set Rg2 = Range("B1:B7")
    
    compRanges Rg1, Rg2
 
End Sub

Option Explicit
 
Sub compare()
    Dim a, b, c, t$, i&, ii&, x&, k
 
    '1.
 
    a = Sheets(1).[a1].CurrentRegion.Value
    b = Sheets(2).[a1].CurrentRegion.Value
 
    '2.
    ReDim c(1 To UBound(a) + UBound(b), 1 To UBound(a, 2))
 
    '3.
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(b)
            t = b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5)
 
            If .exists(t) Then
                .Item(t) = 0
            Else
                ii = ii + 1
                For x = 1 To UBound(b, 2)
                    c(ii, x) = b(i, x)
                Next
            End If
        Next
 
        For Each k In .keys
            If .Item(k) <> 0 Then
                i = .Item(k): ii = ii + 1
                For x = 1 To UBound(a, 2)
                    c(ii, x) = a(i, x)
                Next
            End If
        Next
    End With
 
    '5.
    With Sheets(3)
    .[e1].Resize(ii).NumberFormat = "@"
    .[a1].Resize(ii, 5) = c
    End With
End Sub

Sub ViborDataList()
    Dim sCon$, rs As Object, cn As Object
    Dim sSQL$
    Set cn = CreateObject("ADODB.Connection")
    Select Case CLng(Split(Application.Version, ".")(0))
        Case Is < 12
            sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.FullName _
              & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
        Case Is >= 12
            sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName _
            & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
    End Select
 
    sSQL = "SELECT a.* " _
        & " FROM [Лист1$A:E] AS a" _
        & " WHERE a.Kod NOT IN (SELECT b.Kod FROM [Лист2$A:E] AS b)"
    cn.Open sCon
    Set rs = cn.Execute(sSQL)
    With Sheets("Лист3")
        .Cells(.UsedRange.Rows.Count + 1, 1).CopyFromRecordset rs
    End With
    Set rs = Nothing
    cn.Close
    sSQL = "SELECT b.* " _
        & " FROM [Лист2$A:E] AS b" _
        & " WHERE b.Kod NOT IN (SELECT a.Kod FROM [Лист1$A:E] AS a)"
    cn.Open sCon
    Set rs = cn.Execute(sSQL)
    With Sheets("Лист3")
        .Cells(.UsedRange.Rows.Count + 1, 1).CopyFromRecordset rs
    End With
End Sub

'::: Sh1 - лист с первым списком
'::: aC1() - массив из 4-х элементов с номерами колонок 1-го списка
'::: b1,e1 - первая и последняя строки 1-го списка
 
'::: Sh2 - лист со вторым списком
'::: aC2() - массив из 4-х элементов с номерами колонок 2-го списка
'::: b2,e2 - первая и последняя строки 2-го списка
 
'::: Не забудьте установить ссылку на Microsoft.Scripting
 
Sub compRanges(sh1 As Worksheet, aC1() As Integer, b1 As Long, e1 As Long, _
               sh2 As Worksheet, aC2() As Integer, b2 As Long, e2 As Long)
Dim Dict As Scripting.Dictionary
    Set Dict = New Dictionary
    '::: Грузим весь первый в словарь
    n& = 0
    For i& = b1 To e1
        Key$ = ""
        For j% = 1 To 4
            Key$ = Key$ & Trim$(sh1.Cells(i&, aC1(j%))) & " "
        Next j%
        Dict.Add CStr(Key$), n&
        n& = n& + 1
    Next
    '::: Проверяем второй
    For i& = b2 To e2
        Key$ = ""
        For j% = 1 To 4
            Key$ = Key$ & Trim$(sh2.Cells(i&, aC2(j%))) & " "
        Next j%
        If Not Dict.Exists(Key$) Then Debug.Print "Нет в первом, есть во втором: "; Key$
    Next i&
    Dict.RemoveAll
    '::: Грузим весь второй в словарь
    n& = 0
    For i& = b2 To e2
        Key$ = ""
        For j% = 1 To 4
            Key$ = Key$ & Trim$(sh1.Cells(i&, aC2(j%))) & " "
        Next j%
        Dict.Add CStr(Key$), n&
        n& = n& + 1
    Next
    '::: Проверяем первый
    For i& = b1 To e1
        Key$ = ""
        For j% = 1 To 4
            Key$ = Key$ & Trim$(sh2.Cells(i&, aC1(j%))) & " "
        Next j%
        If Not Dict.Exists(Key$) Then Debug.Print "Нет во втором, есть в первом: "; Key$
    Next i&
    Set Dict = Nothing
End Sub
 
Sub Test()
Dim C1(1 To 4) As Integer
Dim C2(1 To 4) As Integer
    C1(1) = 1
    C1(2) = 2
    C1(3) = 3
    C1(4) = 4
    C2(1) = 7
    C2(2) = 8
    C2(3) = 9
    C2(4) = 10
 
    '::: Сравниваем списки с третьего листа: 
    '::: первый - в колонках 1-4; второй - в 7-10
 
    compRanges Sheets(3), C1(), 1, 5, _
               Sheets(3), C2(), 1, 5
 
End Sub

Sub ListDifferencesWithColumnDifferences()
    Dim s(2) As Worksheet, r(2) As Range
    For i = 0 To 2
        Set s(i) = Sheets(i + 1)
        Set r(i) = s(i).Range(s(i).Cells(1), s(i).Cells(65535, 1).End(xlUp))
    Next i
    For i = 0 To 1
        With r(i).Offset(, 5)
            .FormulaR1C1 = "=ISNA(VLOOKUP(RC1," & s(1 - i).Name _
            & "!" & r(1 - i).Address(ReferenceStyle:=xlR1C1) & ",1,0))"
            .Value = .Value
            .Cells(1) = False
            .ColumnDifferences(.Cells(1)).EntireRow.Copy r(2).Offset(1).EntireRow
            .ClearContents
            Set r(2) = r(2).End(xlDown)
        End With
    Next i
    s(2).Columns(6).ClearContents
End Sub