Question

我正在尝试创建一个比较两个Excel文件的宏。两个Excel文件的唯一一个共同点是＆＃34; eRequest ID＆＃34;。目标是显示任何没有＆＃34; eRequest ID＆＃34;在两个文件中。

例如，如果仅在两个文件之一中找到记录1，则必须显示它。唯一不显示记录的情况是＆＃34; eRequest ID＆＃34;在两个文件中都可以找到。

侧面说明..我录制了一个简单的宏来过滤掉一些字段......我必须将这一部分添加到最终的宏中。

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

我的简短回答：您需要构建一个包含每个工作簿的数组＆＃39;唯一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

假设源工作簿已打开，listobjects位于第一张工作表中。调整工作簿名称和工作表索引/名称以适应：

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

Excel VBA比较两个工作簿

2 个答案: