Compare two worksheets using VBA in Microsoft Excel

With the macro below it is possible to compare excel sheets.
The result is displayed in a new workbook listing all cell differences.

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim r As Long, c As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim rptWB As Workbook, DiffCount As Long
    Application.ScreenUpdating = False
    Application.StatusBar = "Creating the report..."
    Set rptWB = Workbooks.Add
    Application.DisplayAlerts = False
    While Worksheets.Count > 1
        Worksheets(2).Delete
    Wend
    Application.DisplayAlerts = True
    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    For c = 1 To maxC
        Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
        For r = 1 To maxR
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = ws1.Cells(r, c).FormulaLocal
            cf2 = ws2.Cells(r, c).FormulaLocal
            On Error GoTo 0
            If cf1 <> cf2 Then
                DiffCount = DiffCount + 1
                Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
            End If
        Next r
    Next c
    Application.StatusBar = "Formatting the report..."
    With Range(Cells(1, 1), Cells(maxR, maxC))
        .Interior.ColorIndex = 19
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error Resume Next
        With .Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
        End With
        On Error GoTo 0
    End With
    Columns("A:IV").ColumnWidth = 20
    rptWB.Saved = True
    If DiffCount = 0 Then
        rptWB.Close False
    End If
    Set rptWB = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
        "Compare " & ws1.Name & " with " & ws2.Name
End Sub

This example macro shows how to use the macro above:

Sub TestCompareWorksheets()
    ' compare two different worksheets in the active workbook
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
    ' compare two different worksheets in two different workbooks
    CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
        Workbooks("WorkBookName.xls").Worksheets("Sheet2")
End Sub

In this way we can compare 2 files.

Comments

  1. Hi
    I need help to write macro to compare two sheets in excel, sheet1 and sheet2 on same excel book and display all the differences between both the sheets on sheet3. My headings will always be the same between sheet1 and sheet2 but the information in both the sheets may vary. I included the headings that will be on both the sheets:

    ID Number Date of Birth Payroll Number Surname First Name Salary Member Group

    I am struggling with this. So please extend your helping hands Thank you.

  2. Jagadeesh Mani

    i've a macro script to identify the matching column value in two open excel(Column A in first excel and column A in second excel) . I need matching column values to be copied to new excel(third excel) in column A. Please guide me.

    Sub Compare()

    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim Cell As Range
    Dim sBook As String

    If Workbooks.Count < 2 Then
    MsgBox "Error: Only one Workbook is open" & vbCr & _
    "Open a 2nd Workbook and run this macro again."
    Exit Sub
    End If

    Set wb1 = ThisWorkbook
    For Each wb2 In Workbooks
    If wb2.Name wb1.Name Then Exit For
    Next

    On Error Resume Next
    ReDo1:
    Application.DisplayAlerts = False
    sBook = Application.InputBox(Prompt:= _
    "Compare this workbook (" & wb1.Name & _
    ") to...?", _
    Title:="Compare to what workbook?", _
    Default:=wb2.Name, _
    Type:=2)
    If sBook = "False" Then Exit Sub
    If Workbooks(sBook) Is Nothing Then
    MsgBox "Workbook: " & sBook & " is not open."
    GoTo ReDo1
    Else
    Set wb2 = Workbooks(sBook)
    End If

    Application.ScreenUpdating = False
    For Each ws1 In wb1.Sheets
    If Not wb2.Sheets(ws1.Name) Is Nothing Then
    Set ws2 = wb2.Sheets(ws1.Name)
    For Each Cell In ws1.UsedRange
    If Cell.Formula = ws2.Range(Cell.Address).Formula Then
    Cell.Interior.ColorIndex = 35
    ws2.Range(Cell.Address). _
    Interior.ColorIndex = 35
    End If
    Next Cell
    If ws1.UsedRange.Rows.Count = _
    ws2.UsedRange.Rows.Count Or _
    ws1.UsedRange.Columns.Count = _
    ws2.UsedRange.Columns.Count Then
    For Each Cell In ws2.UsedRange
    If Cell.Formula = ws1.Range(Cell.Address).Formula Then
    Cell.Interior.ColorIndex = 35
    ws1.Range(Cell.Address). _
    Interior.ColorIndex = 35
    End If
    Next Cell
    End If
    End If
    Next ws1

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    End Sub

  3. I recieve an error:

    Sub TestCompareWorksheets()
    ' compare two different worksheets in the active workbook
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
    ' compare two different worksheets in two different workbooks
    CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
    Workbooks("WorkBookName.xls").Worksheets("Sheet2")

    ------- CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
    Workbooks("WorkBookName.xls").Worksheets("Sheet2") -> for me it tells 'subscript out of range (Error 9)' but when i delete it - sub works fine... so is it neccesary codeline?

  4. I want to write a comparison macro between sheet 1 and sheet 2 where result will be displayed in sheet 3 in terms of True/False. Can anyone help me on this?

  5. This macro working and being help a lot. Thank you for sharing it. Is there any way to inculde the column name in results sheet? It will be more informative if results sheet diplay the records which has differences along with Coulmn name?

  6. I can get this code to work:
    CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")

    but when I try the alternate
    ' compare two different worksheets in two different workbooks
    CompareWorksheets ActiveWorkbook.Worksheets("Sheet1"), _
    Workbooks("WorkBookName.xls").Worksheets("Sheet2")

    I get an error. My troubleshooting included:
    Saving the workbook as an .xlsm file, renaming the sheets to compare, having the WB open, having it closed, moving the reference file to the same folder location as the active file, moving it to a different location as the active file. Maybe a couple other things too, I can't remember everything I tried.

    The code I'm using is exactly what you have only I put in my file name and worksheet numbers:

    CompareWorksheets ActiveWorkbook.Worksheets("24G"), _ Workbooks("S:\PD042\WORK\user name\P42-2 Bookplan-Tracking\P42-2 AMM Total Tracking Load Two.xlsm").Worksheets("24")

    Does anything stand out to you as incorrect? or should this work as expected?

  7. "You just have to copy the two example procedures above and paste them into a normal module sheet in your workbook (you can't use the sheet modules).

    Open a workbook that contains two sheets you want to compare.
    Edit the sheet names used in the macro ""TestCompareWorksheets"" (or, if you are lazy, rename the sheets in the workbook).

    In Excel you press Alt+F8 to open the macro dialog box and run this macro: ""TestCompareWorksheets"".

    A more detailed description of this procedure is available here:
    http://www.erlandsendata.no/english/vba/howto.php "

  8. "You just have to copy the two example procedures above and paste them into a normal module sheet in your workbook (you can't use the sheet modules).

    Open a workbook that contains two sheets you want to compare.
    Edit the sheet names used in the macro ""TestCompareWorksheets"" (or, if you are lazy, rename the sheets in the workbook).

    In Excel you press Alt+F8 to open the macro dialog box and run this macro: ""TestCompareWorksheets"".

    A more detailed description of this procedure is available here:

    • I see error "Sub script out of range" while running
      ub TestCompareWorksheets()
      ' compare two different worksheets in the active workbook
      CompareWorksheets Worksheets("Sheet1"), Worksheets("Sheet2")
      End Sub

      Please help

Leave a Reply to Adel Cancel reply

Your email address will not be published. Required fields are marked *

Terms and Conditions of use

The applications/code on this site are distributed as is and without warranties or liability. In no event shall the owner of the copyrights, or the authors of the applications/code be liable for any loss of profit, any problems or any damage resulting from the use or evaluation of the applications/code.