匹配两个列表，然后并排放置

Question

我有两个要与第三个列表匹配的列表。如果它们匹配，我想按中间列表来组织它们。我知道这听起来有些混乱，所以我张贴了一张图片来解释我在说什么。

我从此列表开始：使用中间列，我想相应地匹配每一行。

正确的列表如下：

对于没有匹配项的剩菜，我想创建一个新行，从中间列表开始，然后是第一个列表，然后是第三列。

这样的列表如下：

Sub MatchNSortOTest()
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"))

    Cells(r, "Z").Value = MyAnswer

    If MyAnswer = 1 Then
    MyAnswer = Application.WorksheetFunction.Application.VLookup(myLookup, ThisWorkbook.Sheets("Sheet1").Range("AB18:AB999"), 1, 0)
    Cells(r, "B").Value = MyAnswer

    'Check if off the list
    myCheck = ThisWorkbook.Sheets("Sheet1").Cells(r, "B")
    Check = Application.WorksheetFunction.Application.VLookup(myCheck, ThisWorkbook.Sheets("Sheet1").Range("AB18:AB999"), 1, 0)
    Cells(r, "C").Value = MyAnswer


    ElseIf MyAnswer = 0 Then
    Cells(r, "B").Value = ""

    End If



 Next r

 'Sheets("Sheet1").Range("AB18:AC999").ClearContents
 'Call MatchNSortW

End Sub