vba - 比较 2 excel 表与公共键

问题描述

我正在尝试与具有 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

标签： vbaexcel

vba - 比较 2 excel 表与公共键

问题描述

解决方案

推荐阅读