Macro (VBA) - Compare Two Excel file RRS feed

  • Question

  • Hello,

    I have two different excel files Column A to F, where one field is common in both the files i.e. Column A.

    I need macro which will compare both files and identifying and listing of unreconciled line wise items.

    Thanks & Regards,


    Friday, May 17, 2019 5:16 PM

All replies

  • Run this macro with the two files closed, and choose them when prompted. If you data sets do not start in A1 with no blanks, then the code will ask you to select the data.

    Sub QuickCompare()
        Dim sht1 As Worksheet
        Dim sht2 As Worksheet
        Dim sht3 As Worksheet
        Dim rngC As Range
        Dim rngS As Range
        Dim rngT As Range
        Dim lngCol As Long
        Dim lngCols As Long
        Dim varArray As Variant
        Dim i As Integer
        Dim j As Integer
        Dim lngUsed As Long
        Dim strName As String
        With Application
            xlCalc = .Calculation
            .Calculation = xlCalculationManual
            .EnableEvents = False
            .DisplayAlerts = False
        End With

        'Start with the new two-sheet workbook
        Set wkbkDBCompare = Workbooks.Add
        With wkbkDBCompare
            If .Worksheets.Count = 1 Then
            End If
            MsgBox "In the next dialog, select the first file"
            strName = Application.GetOpenFilename(Title:="Select first file")
            If strName = "False" Then
                wkbkDBCompare.Close False
                GoTo FinishUp
            End If
            Set wkbk1 = Workbooks.Open(strName)
            If wkbk1.Worksheets.Count = 1 And _
                wkbk1.Worksheets(1).UsedRange.Address = wkbk1.Worksheets(1).Range("A1").CurrentRegion.Address And _
                Application.CountBlank(wkbk1.Worksheets(1).UsedRange) = 0 Then
                    Set rng1 = wkbk1.Worksheets(1).UsedRange
                MsgBox "In the next dialog, select a cell in the database from " & wkbk1.Name
                Set rng1 = Application.InputBox("Select a cell in the database", Default:="=A1", Type:=8)
            End If
            Set sht1 = .Worksheets(1)
            sht1.Name = "File one"
            sht1.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
            MsgBox "In the next dialog, select the second file"
            strName = Application.GetOpenFilename(Title:="Select first file")
            If strName = "False" Then
                wkbkDBCompare.Close False
                wkbk1.Close False
                GoTo FinishUp
            End If

            Set wkbk2 = Workbooks.Open(strName)
            If wkbk2.Worksheets.Count = 1 And _
                wkbk2.Worksheets(1).UsedRange.Address = wkbk1.Worksheets(1).Range("A1").CurrentRegion.Address And _
                Application.CountBlank(wkbk2.Worksheets(1).UsedRange) = 0 Then
                    Set rng2 = wkbk2.Worksheets(1).UsedRange
                MsgBox "In the next dialog, select a cell in the database from " & wkbk2.Name
                Set rng2 = Application.InputBox("Select a cell in the database", Default:="=A1", Type:=8)
            End If
            Set sht2 = .Worksheets(2)
            sht2.Name = "File two"
            sht2.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
        End With
        'Set the ID cells in the first columns of the two sheets
        With sht1
            .Range("A1").Value = "Source"
            With .Range(.Range("A2"), .Cells(.Rows.Count, "B").End(xlUp)(1, 0))
                .Formula = "=""" & wkbk1.Name & " " & sht1.Name & ", row "" & ROW()"
                .Value = .Value
            End With
        End With
        With sht2
            .Range("A1").Value = "Source"
            With .Range(.Range("A2"), .Cells(.Rows.Count, "B").End(xlUp)(1, 0))
                .Formula = "=""" & wkbk2.Name & " " & sht2.Name & ", row "" & ROW()"
                .Value = .Value
            End With
        End With
        wkbk1.Close False
        wkbk2.Close False
        'Check that the headers are exact
        For i = 1 To sht1.UsedRange.Columns.Count
            If sht1.Cells(1, i).Value <> sht2.Cells(1, i).Value Then
                MsgBoxResult1 = MsgBox("The headers in the first row don't match exactly." & Chr(10) & _
                """Yes"" to delete " & sht1.Cells(1, i).Value & Chr(10) & _
                """No"" to delete " & sht2.Cells(1, i).Value & Chr(10) & _
                """Cancel"" to Exit and start over", vbYesNoCancel)
                If MsgBoxResult1 = vbYes Then
                    sht1.Cells(1, i).EntireColumn.Delete
                    i = i - 1
                End If
                If MsgBoxResult1 = vbNo Then sht2.Cells(1, i).EntireColumn.Delete
                If MsgBoxResult1 = vbCancel Then
                    wkbkDBCompare.Close False
                    GoTo FinishUp
                End If
            End If
        Next i
        'Prepare the array of compared columns for the Remove Duplicates function
        lngCols = sht1.UsedRange.Columns.Count
        ReDim varArray(0 To lngCols - 2)
        For lngCol = 2 To lngCols
            varArray(lngCol - 2) = lngCol
        'Create the "Differences" sheet by copying sheet 1
        On Error Resume Next
        sht1.Copy Before:=wkbkDBCompare.Worksheets(1)
        Set sht3 = wkbkDBCompare.Worksheets(1)
        sht3.Name = "Differences"
        'Copy the values - not headers - from the second sheet to the bottom of the Differences sheet
        sht2.UsedRange.Offset(1).Copy sht3.Cells(sht3.Rows.Count, "A").End(xlUp)(2)
        'Remove duplicates
        sht3.UsedRange.RemoveDuplicates Columns:=(varArray), Header:=xlYes
        'Find the first cell in column A that contains sheet2's name
        Set rngC = sht3.Range("A:A").Find(sht2.Name, sht3.Range("A1"), xlValues, xlPart)
        'See if the name was found - if not, then
        'all the values from the second sheet were
        'found on the first sheet, so remove all the
        'values or just those from the from the first sheet
        If rngC Is Nothing Then
            sht3.Range(sht3.Range("A2"), sht3.Cells(sht3.Rows.Count, "A").End(xlUp)).EntireRow.Delete
            sht3.Range(sht3.Range("A2"), rngC(0)).EntireRow.Delete
        End If
        'Prepare the comparison sheet for the second sheet's values
        Set rngT = sht3.Cells(sht3.Rows.Count, "A").End(xlUp)(2)
        sht2.UsedRange.Offset(1).Copy rngT
        'Copy the values from the first sheet
        sht1.UsedRange.Offset(1).Copy sht3.Cells(sht3.Rows.Count, "A").End(xlUp)(2)
        'Set the remove duplicates range
        Set rngC = sht3.Range(rngT, sht3.Cells(sht3.Rows.Count, "A").End(xlUp)).EntireRow
        'Remove the duplicates
        rngC.RemoveDuplicates Columns:=(varArray), Header:=xlNo
        'See if any rows from the first sheet remain
        Set rngS = sht3.Range("A:A").Find(sht1.Name, rngT, xlValues, xlPart)
        'If no cells with sheet 1's name were found, all rows were duplicates
        'so remove - just from the comparison range - all the
        'values or just those from the from the second sheet
        If rngS Is Nothing Then
            sht3.Range(rngT, sht3.Cells(sht3.Rows.Count, "A").End(xlUp)).EntireRow.Delete
            sht3.Range(rngT, rngS(0)).EntireRow.Delete
        End If
        'Clean up the original sheets to get rid of the ID columns
        'See if there are any remaining non-duplicates
        'If so, highlight the differences
        With sht3
            If .Cells(.Rows.Count, "A").End(xlUp).Row = 1 Then
                MsgBox "Everything looks good - the DBs match entirely, so there were no differences."
                Application.DisplayAlerts = False
                wkbkDBCompare.Close True
                GoTo FinishUp
            End If
        End With
        'Otherwise, sort the cells and highlight differences
        With sht3
            With .Sort
                .SortFields.Add Key:=sht3.Range("B1"), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .SetRange sht3.Cells
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
            End With
            For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row Step 2
                For j = 3 To .Cells(1, .Columns.Count).End(xlToLeft).Column
                    If .Cells(i, j).Value <> .Cells(i + 1, j).Value Then
                        .Cells(i, j).Resize(2, 1).Interior.ColorIndex = 3
                    End If
                Next j
            Next i
            MsgBox "The 2 DBs do not match exactly."
        End With

        wkbkDBCompare.SaveAs "DB Comparison " & Format(Date, "yyyy-mm-dd") & ".xlsx", xlOpenXMLWorkbook

        With Application
            .EnableEvents = True
            .DisplayAlerts = True
            On Error GoTo noCalc
            .Calculation = xlCalc
            Exit Sub
            .Calculation = xlCalculationAutomatic
        End With
    End Sub

    Tuesday, May 21, 2019 9:38 PM