excel - 比较两个excel文件vba

Question

寻找一个 VBA 代码，我可以在其中比较来自两个不同 excel 文件的数据并在第三个 excel 文件中添加输出。
文件可以包含它必须验证的 N 列和 N 行。

我有一个代码来比较 2 张纸，但我需要如下所示的输出。
(此 vba 代码将打开 excel 文件以读取数据)
Output of data after comparing

Sub Compare()

Dim WorkRng1 As Range, WorkRng2 As Range, Rng1 As Range, Rng2 As Range

Set objWorkbook1 = Workbooks.Open("F:\Learning\Book1.xlsx")
Set objWorkbook2 = Workbooks.Open("F:\Learning\Book2.xlsx")

Set objWorksheet1 = objWorkbook1.Worksheets(1)
Set objWorksheet2 = objWorkbook2.Worksheets(1)


Set WorkRng1 = objWorksheet1.UsedRange
Set WorkRng2 = objWorksheet2.UsedRange

For Each Rng1 In WorkRng1
    Rng1.Value = Rng1.Value
    For Each Rng2 In WorkRng2
        If Rng1.Value = Rng2.Value Then
            
            

            Exit For
        End If
    Next
Next


End Sub

像这样要求输出

Name_Book1    | Name_Book2 |  Compare |   Amount_book1 |  Amount_book2|   Compare 
Store_1       | Store_1    | Pass     | 362            | 420           | Fail
Store_2       | Store_2    | Pass     | 400            | 360           |Fail
Store_3       | Store_3    | Pass     | 922            | 520           | Fail
Store_4       | Store_4    | Pass     | 600            | 320           | Fail
Store_5       | Store_5    | Pass     | 400            | 400           | Pass

其他代码不会打开文件，但我需要比较数据并获得上面的输出。

Excel File 1 | Excel File 2 | Output file

Sub GetDataFromSingleCell(cell As String)

Dim srcCN As Object ' ADODB.Connection
Dim srcRS As Object ' ADODB.Recordset

Set srcCN = CreateObject("ADODB.Connection")
Set srcRS = CreateObject("ADODB.Recordset")

srcCN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & CStr("F:\Learning\Book1.xlsx") & _
            ";" & "Extended Properties=""Excel 12.0;HDR=No;"";"

srcRS.Open "SELECT * FROM [Sheet1$" & cell & ":" & cell & "];", srcCN, 3, 1  'adOpenStatic, adLockReadOnly

srctxt = srcRS.Fields(0).Value

Dim trgCN As Object ' ADODB.Connection
Dim trgRS As Object ' ADODB.Recordset

Set trgCN = CreateObject("ADODB.Connection")
Set trgRS = CreateObject("ADODB.Recordset")

trgCN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & CStr("F:\Learning\Book2.xlsx") & _
            ";" & "Extended Properties=""Excel 12.0;HDR=No;"";"

trgRS.Open "SELECT * FROM [Sheet1$" & cell & ":" & cell & "];", trgCN, 3, 1  'adOpenStatic, adLockReadOnly

trgtxt = trgRS.Fields(0).Value

If srctxt = trgtxt Then
    Sheet1.Cells(1, 2) = "Passed"
Else
    Sheet1.Cells(1, 2) = "Failed"
End If

End Sub

输出文件包含 VBA 代码供引用使用。
也许像上面那样读取与 excel 文件相同的 txt 文件会很好。

Answer 1

尝试这个。
在运行代码的工作簿中，您将需要一个名为“比较”的工作表。

Sub Compare()

    Dim Rng1 As Range, Rng2 As Range, arr1, arr2, arrOut
    Dim rw As Long, col As Long, c As Long, v1, v2
    
    'open workbooks and assign ranges  
    Set Rng1 = Workbooks.Open("F:\Learning\Book1.xlsx").Worksheets(1).UsedRange
    Set Rng2 = Workbooks.Open("F:\Learning\Book2.xlsx").Worksheets(1).UsedRange
   
    'check ranges are comparable 
    If Rng1.Rows.Count <> Rng2.Rows.Count Or _
       Rng1.Columns.Count <> Rng2.Columns.Count Then
        MsgBox "Ranges are different sizes!"
        Exit Sub
    End If
    
    'faster to read from arrays...
    arr1 = Rng1.Value
    arr2 = Rng2.Value
    'size array for output (need 3 output columns per input column)
    ReDim arrOut(1 To UBound(arr1, 1), 1 To 3 * UBound(arr1, 2))
    
    For rw = 1 To UBound(arr1, 1)
        c = 1 'start column position in output array
        For col = 1 To UBound(arr1, 2)
            v1 = arr1(rw, col)
            v2 = arr2(rw, col)
            If rw = 1 Then
                'column headers here...
                arrOut(rw, c) = v1 & "_book1"
                arrOut(rw, c + 1) = v2 & "_book2"
                arrOut(rw, c + 2) = "Compare"
            Else
                'column values comparison
                arrOut(rw, c) = v1
                arrOut(rw, c + 1) = v2
                arrOut(rw, c + 2) = IIf(v1 = v2, "Pass", "Fail")
            End If
            c = c + 3
        Next col
    Next rw
    
    'put result array on worksheet
    With ThisWorkbook.Sheets("Compare")
        .UsedRange.ClearContents
        .Range("A1").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
    End With
    
End Sub