Question

我正在尝试与具有40000行和35列数据的Excel工作表进行比较。 A列中有一个公用密钥，但是两张表中的数据都不一样。

在工作表1中可能有

A
B
C
D

并且在sheet2中可能有

A
C
D
E

因此，我想将两者进行比较，并在摘要表中提供区别。我已经编写了代码，但不知道如何完成它。

Option Explicit

Sub Compare_Two_Excel_Files_Highlight_Differences()
    'Define Object for Excel Workbooks to Compare
    Dim sh As Integer, ShName As String, lColIdx As Long, sIdx As Long, ssh As String
    Dim F1_Workbook As Workbook, F2_Workbook As Workbook, statmsg As String, trialcnt As Long
    Dim iRow As Double, iCol As Double, iRow_Max As Double, iCol_Max As Double
    Dim File1_Path As String, File2_Path As String, F1_Data As String, F2_Data As String, Header As String


    'Assign the Workbook File Name along with its Path
    File1_Path = ThisWorkbook.Sheets("Settings").Cells(2, 2)
    File2_Path = ThisWorkbook.Sheets("Settings").Cells(3, 2)
    iRow_Max = ThisWorkbook.Sheets("Settings").Cells(4, 2)
    iCol_Max = ThisWorkbook.Sheets("Settings").Cells(5, 2)
    lColIdx = ThisWorkbook.Sheets("Settings").Cells(6, 2).Interior.ColorIndex

    'Open Files To Compare
    Set F2_Workbook = Workbooks.Open(File2_Path)
    Set F1_Workbook = Workbooks.Open(File1_Path)

'    Windows("File1_Path.xlsx").Activate
'    Columns("A:A").Select
'    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'    Range("A1").Select
'    ActiveCell.FormulaR1C1 = "Key"
'    Range("A2").Select
'    Windows("File2_Path.xlsx").Activate
'    Columns("A:A").Select
'    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'    Range("A1").Select
'    ActiveCell.FormulaR1C1 = "Key"
'    Range("A2").Select


    'With F1_Workbook object, now it is possible to pull any data from it
    'Read Data From Each Sheets of Both Excel Files & Compare Data
    sIdx = 1
'   trialcnt = 1
    Header = 1
    ThisWorkbook.Sheets("Summary").Cells.Clear
    ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Workbook.Name
    ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F2_Workbook.Name
    ThisWorkbook.Sheets("Summary").Activate
    statmsg = Application.StatusBar
    For sh = 1 To F1_Workbook.Sheets.Count
        ShName = F1_Workbook.Sheets(sh).Name
        ThisWorkbook.Sheets("Settings").Cells(7 + sh, 1) = ShName
        ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) = "Identical Sheets"
        ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2).Interior.Color = vbWhite
        Application.StatusBar = statmsg & " ,Processing Sheet: " & ssh

    '    If ThisWorkbook.Sheets("Settings").Cells(4, 2) = 0 Then iRow_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Row
    '    If ThisWorkbook.Sheets("Settings").Cells(5, 2) = 0 Then iCol_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Column
    '    For iRow = 1 To iRow_Max
    '    For iCol = 1 To iCol_Max
    '        F1_Data = F1_Workbook.Sheets(ShName).Cells(iRow, iCol)
    '        F2_Data = F2_Workbook.Sheets(ShName).Cells(iRow, iCol)


        'Compare Data From Excel Sheets & Highlight the Mismatches
        '   Find row number

        Dim Row As Long
        Dim i As Integer
    For i = 2 To ThisWorkbook.Sheets("Settings").Cells(4, 2).Value

        On Error Resume Next
        Row = Application.WorksheetFunction.Match(F1_Workbook.Sheets(ShName).Cells(i, 1).Value, F1_Workbook.Sheets(ShName).Range("A1:A200"), 0)


        On Error GoTo 0

        If lRow > 0 Then
        'code


'        If ThisWorkbook.Sheets("Settings").Cells(4, 2) = 0 Then iRow_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Row
'        If ThisWorkbook.Sheets("Settings").Cells(5, 2) = 0 Then iCol_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Column
'        For iRow = 1 To iRow_Max
'        For iCol = 1 To iCol_Max


        F1_Data = F1_Workbook.Sheets(ShName).Cells(i, iCol)
        F2_Data = F2_Workbook.Sheets(ShName).Cells(Row, iCol)


            If F1_Data <> F2_Data Then
  '             F1_Workbook.Sheets(ShName).Cells(iRow, iCol).Interior.ColorIndex = lColIdx
                ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) = "Mismatch Found"
                ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2).Interior.ColorIndex = lColIdx
                If ssh <> F1_Workbook.Sheets(sh).Name Then
                    sIdx = sIdx + 1
                    ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Workbook.Sheets(sh).Name
                    ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F2_Workbook.Sheets(sh).Name
                    ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(1, 1).Value
                    ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = "Field"
                    ssh = F1_Workbook.Sheets(sh).Name

                End If
                sIdx = sIdx + 1
            '   ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(iRow, iCol).Address
                ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = F1_Workbook.Sheets(ShName).Cells(Header, iCol).Value
                ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(iRow, 1).Value
                ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Data
                ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F2_Data
                ThisWorkbook.Sheets("Summary").Cells(sIdx, 2).Select
            End If
   '     Next iCol


        ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) = ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) & " (" & iRow_Max & "-Rows , " & iCol_Max & "-Cols Compared)"
  '  Next sh

    Next i
End If
Trial_Exit:
    '''''Process Completed
    F2_Workbook.Close savechanges:=False
    F1_Workbook.Close savechanges:=True
    Set F2_Workbook = Nothing
    Set F1_Workbook = Nothing
    ThisWorkbook.Sheets("Settings").Activate
    MsgBox "Task Completed"
    Application.StatusBar = statmsg

 '   End With
 '   ThisWorkbook.Sheets("Settings").Cells(1, 4).Font.Color = vbRed
End Sub

Answer 1

好吧，将它们放在一起只是为了显示您可以进行匹配，结果是结果在列表中的位置。

编辑：仅显示在处理其他工作表时公式如何变化，即工作表1和2上的数据列表以及工作表3上的匹配项：

Answer 2

我知道您正在要求执行此操作的代码，但是如果您使用的是Excel 2013或更高版本，则有一个名为Inquire的加载项可以为您执行此操作。如果转到文件>选项>加载项> COM加载项>选中查询。

如果打开两个工作表，请单击“查询”功能区，然后选择“比较文件”。它将比较这两个文件，并使用结果创建一个新的工作簿。

此工具还有很多其他很酷的功能，您无需编写任何代码。

这是您可以尝试使用的代码：

Sub wsCompare()
    Dim ws1 As Worksheet, ws2 As Worksheet, wsResults As Worksheet
    Dim strKey As String
    Dim lngFindKey As Long
    Dim rngFindKey As Range

    Set ws1 = Sheets("Sheet1") 'set this to your first worksheet with data
    Set ws2 = Sheets("Sheet2") 'set this to your second worksheet with data
    Set wsResults = Sheets("Sheet3") 'set this to the worksheet with the results in it

    For i = 1 To 4000 'update this to be the first row containing an ID to the last
        strKey = ws1.Range("A" & i).Value
        Set rngFindKey = ws2.Range("A:A").Find(WHAT:=strKey)
        lngFindKey = rngFindKey.Row

        For x = 1 To 35
            If x = 1 Then
                wsResults.Range("A" & i).Value = strKey
            Else
                'add code to calc your difference assuming all numerical values do something like this
                wsResults.Range(Cells(i, x)).Value = ws2.Range(Cells(longFindKey, x)).Value - ws1.Range(Cells(i, x)).Value
            End If
        Next x
    Next i

End Sub

比较2个Excel表和公共密钥

2 个答案: