Попытка сопоставить данные с помощью VLookup после копирования и вставки

Question

Я пытаюсь сравнить данные дважды после первоначального сравнения.Я использовал несколько макросов, в которых был вызван основной макрос для выполнения этого метода, но я все еще сталкиваюсь с проблемой.

Первое начальное сравнение начинается, когда я сравниваю столбцы B и G сСтолбец E. (Рисунок 1) Затем любые оставшиеся данные из столбцов B начинают формировать список в столбце Z, а оставшиеся данные из столбца G начинают формировать список в столбце AJ (рисунок 2).

Рисунок 1 Рисунок 2

Моя проблема в том, что я хотел бы вырезать данные из столбцов Z и AJ и добавить их обратнов столбцах B и G, сохраняя тот же формат состава, сравнивая эти два столбца.Если они не совпадают, я хотел бы создать новую строку и соответственно вставить эти данные.

Мой первый макрос вставляется сюда, при этом каждый макрос вызывается соответственно,

Sub MatchNSortO()
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Sheet1").Range("B18:C999").Cut
ThisWorkbook.Sheets("Sheet1").Range("AB18").Select
ActiveSheet.Paste 'Originals Column

ThisWorkbook.Sheets("Sheet1").Range("G18:H999").Cut
ThisWorkbook.Sheets("Sheet1").Range("AG18").Select
ActiveSheet.Paste 'Working Column
SendKeys ("{ESC}")
Application.ScreenUpdating = True




For r = 18 To Cells(Rows.Count, "E").End(xlUp).row     ' From row 1 to the 
last row with data
On Error Resume Next

myCountif = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")
myLookup = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")

MyAnswer = 
Application.WorksheetFunction.Application.Countif(Range("AB18:AB999"), 
Cells(r, "E"))

If MyAnswer = 1 Then
Match = Application.WorksheetFunction.Application.VLookup(myLookup, 
ThisWorkbook.Sheets("Sheet1").Range("AB18:AB999"), 1, 0)
Cells(r, "B").Value = Match
myFiletype = ThisWorkbook.Sheets("Sheet1").Cells(r, "B")
FileExt = Application.WorksheetFunction.Application.VLookup(myFiletype, 
ThisWorkbook.Sheets("Sheet1").Range("AB18:AC999"), 2)
Cells(r, "C").Value = FileExt
ElseIf MyAnswer = 0 Then
Cells(r, "B").Value = ""

End If
Next r
Call CompareOriginal
Call MatchNSortW
Call CompareWorking
End Sub

Sub CompareOriginal()

Dim i As Long, arrB As Variant, arrAB As Variant, z As Object, rng As Range
Set z = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False

Dim NextRow As Range
Set NextRow = Sheet1.Cells(Cells.Rows.Count, 2).End(xlUp).Offset(1, 0)

 With Worksheets("sheet1")

    arrB = .Range(.Cells(18, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
    arrAB = .Range(.Cells(18, "AB"), .Cells(.Rows.Count, 
   "AB").End(xlUp)).Value

    For i = LBound(arrAB, 1) To UBound(arrAB, 1)
        If arrAB(i, 1) <> vbNullString Then
            If IsError(Application.Match(arrAB(i, 1), arrB, 0)) Then
                z.Item(arrAB(i, 1)) = vbNullString
            End If
        End If
    Next i

    .Cells(18, "Z").Resize(z.Count, 1) = Application.Transpose(z.keys)
    'Sheets(1).Range("Z18:Z999").Copy

    'Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Select
    'Cells(Rows.Count, 2).End(xlUp).Offset(2, -1).Interior.Color = vbGreen
    'Cells(Rows.Count, 2).End(xlUp).Offset(2, -1).Value = "Drawings Not 
     Found In ECM Spreadsheet"
    'Cells(Rows.Count, 2).End(xlUp).Offset(2, 0).Select

    '.Cells(18, "Z").Resize(z.Count, 1) = Application.Transpose(z.keys)
    'Sheets(1).Range("Z18:Z999").Cut
    'ActiveSheet.Paste
    'For Each rng In Selection

     '   rng.Offset(0, 1) = Application.WorksheetFunction.VLookup(rng, 
     Range("AB18:AB999"), 2)

    '    If IsEmpty(Cells(rng, "B")) Then Exit For
    'Next rng


End With
'Sheets("Sheet1").Range("Z18:AC999").ClearContents
End Sub

Sub MatchNSortW()

On Error Resume Next
For r = 18 To Range("E" & Rows.Count).End(xlUp).row ' From row 1 to the last 
row with data
On Error Resume Next

myCountif = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")
myLookup = ThisWorkbook.Sheets("Sheet1").Cells(r, "E")

MyAnswer = 
Application.WorksheetFunction.Application.Countif(Range("AG18:AG999"), 
Cells(r, "E"))
Cells(r, "G").Value = MyAnswer

If MyAnswer = 1 Then
MyAnswer = Application.WorksheetFunction.Application.VLookup(myLookup, 
ThisWorkbook.Sheets("Sheet1").Range("AG18:AG999"), 1, 0)
Cells(r, "G").Value = MyAnswer
myFiletype = ThisWorkbook.Sheets("Sheet1").Cells(r, "G")
FileExt = Application.WorksheetFunction.Application.VLookup(myFiletype, 
ThisWorkbook.Sheets("Sheet1").Range("AG18:AH999"), 2)
Cells(r, "H").Value = FileExt
ElseIf MyAnswer = 0 Then
Cells(r, "G").Value = ""

End If


 Next r

 'Sheets("Sheet1").Range("AG18:AH999").ClearContents

   End Sub

 Sub CompareWorking()

Dim i As Long, arrB As Variant, arrAB As Variant, z As Object
Set z = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False

Dim NextRow As Range
Set NextRow = Sheet1.Cells(Cells.Rows.Count, 5).End(xlUp).Offset(1, 0)

With Worksheets("sheet1")

    arrB = .Range(.Cells(18, "G"), .Cells(.Rows.Count, "G").End(xlUp)).Value
    arrAB = .Range(.Cells(18, "AG"), .Cells(.Rows.Count, 
 "AG").End(xlUp)).Value

    For i = LBound(arrAB, 1) To UBound(arrAB, 1)
        If arrAB(i, 1) <> vbNullString Then
            If IsError(Application.Match(arrAB(i, 1), arrB, 0)) Then
                z.Item(arrAB(i, 1)) = vbNullString
            End If
        End If
    Next i

    .Cells(18, "AJ").Resize(z.Count, 1) = Application.Transpose(z.keys)

End With
'Sheets("Sheet1").Range("AG18:AH999").ClearContents
 End Sub