Excel VBA比较两个工作簿

Question

我正在尝试创建一个比较两个Excel文件的宏。 两个Excel文件的唯一共同点是“ eRequest ID ”。 目的是显示两个文件中都没有“ eRequest ID ”的任何记录。

例如，如果仅在两个文件之一中找到记录1，则必须显示它。 不显示记录的唯一情况是在两个文件中都找到了“ eRequest ID ”。

附带说明..我录制了一个简单的宏以过滤掉某些字段...我也必须将此部分添加到最终宏中。

ActiveSheet.ListObjects("Table_JULY15Release_Master_Inventory__2").Range. _
    AutoFilter Field:=2, Criteria1:=Array("90 BIZ - Deferred", _
    "91 GTO - Deferred", "92 BIZ - Dropped", "94 GTO - Duplicate"), Operator:= _
    xlFilterValues
ActiveSheet.ListObjects("Table_JULY15Release_Master_Inventory__2").Range. _
    AutoFilter Field:=4, Criteria1:="Core Banking"

Answer 1

我的简短回答：您需要为每个工作簿的唯一ID建立一个数组，然后针对另一个工作簿的数组进行过滤。
其余记录将不匹配。

工作原型：

Sub vkbthjgljskbr()
Dim wb(1) As Workbook, ws(1) As Worksheet, LastRow(1) As Long, FldCounter(1) As Long, _
ListObj(1) As String, FilterList() As String, OutputList() As String, x As Long, FilterArr() As String, RowNum() As Long
Set wb(0) = Workbooks("temp1")                'defining workbooks
    Set wb(1) = Workbooks("temp2")
Set ws(0) = wb(0).Worksheets("Munka1")        'worksheets
    Set ws(1) = wb(1).Worksheets("Munka1")
FldCounter(0) = 2                             'Fields (if your tables do not start at A1 you may need to create another counter)
    FldCounter(1) = 4
ListObj(0) = "Táblázat1"                      'Names of the list objects, actually you could define them as objects too
    ListObj(1) = "Táblázat1"
For j = 0 To 1                                'grabs the index last row of the worksheet
    LastRow(j) = ws(j).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Next

For j = 0 To 1 'removes filters
    If ws(j).ListObjects(ListObj(j)).ShowAutoFilter Then
        ws(j).ListObjects(ListObj(j)).Range.AutoFilter
    End If
Next

UltLastRow = Application.WorksheetFunction.Max(LastRow(0), LastRow(1)) - 1 'outputs the largest of lastrow indices - 1 to show index 0 is valid
    ReDim FilterList(UltLastRow, 1)  'initial filterlist
    ReDim OutputList(UltLastRow, 1)  'complementer list
    ReDim RowNum(UltLastRow, 1)
    ReDim FilterArr(UltLastRow)

For j = 0 To 1 'creates your initial filter lists
    x = 0
    For i = 2 To LastRow(j) 'assuming your table starts at A1
        FilterList(x, j) = ws(j).Cells(i, FldCounter(j)).Value2
        x = x + 1
    Next
Next

For j = 0 To 1 'applies initial filters
    Erase FilterArr
    ReDim FilterArr(UltLastRow)
    For x = 0 To UltLastRow 'not quite elegant way to slice array
        FilterArr(x) = FilterList(x, 1 - j)
    Next
    ReDim Preserve FilterArr(UltLastRow)
    ws(j).ListObjects(ListObj(j)).Range.AutoFilter Field:=FldCounter(j), Criteria1:=FilterArr, Operator:=xlFilterValues
Next

For j = 0 To 1 'grabs hidden (non-matching) values
    x = 0
    Erase FilterArr
    ReDim FilterArr(UltLastRow)
    For i = 2 To LastRow(j) 'assuming your table starts at A1
        If ws(j).Rows("" & i).Hidden Then
            FilterArr(x) = ws(j).Cells(i, FldCounter(j)).Value2
            x = x + 1
        End If
    Next
    If ws(j).ListObjects(ListObj(j)).ShowAutoFilter Then 'removes filters
        ws(j).ListObjects(ListObj(j)).Range.AutoFilter
    End If
    ws(j).ListObjects(ListObj(j)).Range.AutoFilter Field:=FldCounter(j), Criteria1:=FilterArr, Operator:=xlFilterValues 'applies complementer filter
Next
End Sub

现在，它适用于我的示例工作簿。

Answer 2

假设源工作簿是打开的，列表对象在第一张纸上。 调整工作簿名称和工作表索引/名称以适合：

Sub Tester()
Dim lst1 As ListObject, lst2 As ListObject
Dim c1 As ListColumn, c2 As ListColumn
Dim rngDest As Range

    Set lst1 = Workbooks("WkBk A.xlsx").Sheets(1).ListObjects(1)
    Set lst2 = Workbooks("WkBk B.xlsx").Sheets(1).ListObjects(1)

    Set c1 = lst1.ListColumns("eRequest ID")
    Set c2 = lst2.ListColumns("eRequest ID")

    Set rngDest = ThisWorkbook.Sheets(1).Range("A2")

    CopyIfNotMatched c1, c2, rngDest
    CopyIfNotMatched c2, c1, rngDest

End Sub

Sub CopyIfNotMatched(c1 As ListColumn, c2 As ListColumn, rngDest As Range)
    Dim c As Range, f As Range

    For Each c In c1.DataBodyRange.Cells
        Set f = c2.DataBodyRange.Find(c.Value, , xlValues, xlWhole)
        If f Is Nothing Then
            Application.Intersect(c.EntireRow, _
                    c1.Parent.DataBodyRange).Copy rngDest
            Set rngDest = rngDest.Offset(1, 0)
        End If
    Next c
End Sub