Сравнить два столбца с разных листов и вывести несовпадения на отдельный лист

Option Explicit
 
Sub compare2()
    Dim a, b, c, d, t$, i&, ii&, iii&, x&, k
    Dim Dic1 As Object
 
    Application.ScreenUpdating = False
 
    '1.
 
    a = Sheets("СПРАВОЧНИК").[d5].CurrentRegion.Value
    b = Sheets("ОТЧЕТЫ").[i3].CurrentRegion.Value
 
    '2.
    ReDim c(1 To UBound(a), 1 To UBound(a, 2))
    ReDim d(1 To UBound(b), 1 To UBound(b, 2))
 
    '3.
    Set Dic1 = CreateObject("Scripting.Dictionary")
 
    With Dic1
        For i = 1 To UBound(a)
            t = a(i, 1)
            .Item(t) = i
        Next
 
        '4.
        For i = 1 To UBound(b)
            t = b(i, 1)
 
            If .exists(t) Then
                .Item(t) = 0
            Else
                iii = iii + 1
                For x = 1 To UBound(b, 2)
                    d(iii, 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 Worksheets.Add(After:=Sheets(Sheets.Count))
        .Name = "НЕТ ОТЧЕТА" & Sheets.Count
        .[a2].Resize(ii, 3) = c
    End With
 
    Application.ScreenUpdating = True
 
End Sub

Sub compare3()
    Dim a, b, i&
    Application.ScreenUpdating = False
    a = Sheets("Справочник").UsedRange
    b = Sheets("Отчетная форма").UsedRange.Columns("I")
    With CreateObject("Scripting.Dictionary")
        For i = 4 To UBound(a) '4 так, как 1-я строка пустая
            .Item(a(i, 4)) = a(i, 2)
        Next
        For i = 2 To UBound(b) '2 так, как 1-я строка пустая
            If .exists(b(i, 1)) Then .Remove b(i, 1)
        Next
        Sheets.Add
        ActiveSheet.Name = "НЕТ ОТЧЕТА" & Sheets.Count
        If .Count Then Cells(2, 1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
    End With
    Application.ScreenUpdating = True
End Sub

        If .Count Then
         Cells(1, 1).Resize(.Count, 2).NumberFormat = "@"
         Cells(1, 1).Resize(.Count, 2).Value = Application.Transpose(Array(.keys, .items))
        End If