Compare two worksheets

With the macro below it is possible to compare the content of two worksheets. 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

The example macro below 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

The example macro below is another example on how to use the compare worksheet macro above:

Sub TestCompareWorksheets2()
' lets the user select two workbooks
' compares the first worksheets with each other
Dim strFile(1 To 2) As String, wb(1 To 2) As Workbook, i As Long
    strFile(1) = "Excel Workbooks (*.xls),*.xls,All Files (*.*),*.*"
    strFile(2) = strFile(1)
    For i = 1 To 2
        strFile(i) = Application.GetOpenFilename(strFile(i), 1, _
            "Select Workbook " & i, , False)
        If Len(strFile(i)) < 6 Then Exit Sub ' no file selected
    Next i
    
    Application.ScreenUpdating = False
    For i = 1 To 2
        Set wb(i) = Workbooks.Open(strFile(i), True, True)
    Next i
        
    ' compare the first worksheets in the two workbooks
    CompareWorksheets wb(1).Worksheets(1), wb(2).Worksheets(1)
    
    For i = 1 To 2
        wb(i).Close False ' close workbook without saving changes
        Set wb(i) = Nothing
    Next i
    Erase strFile
    
    Application.ScreenUpdating = True
End Sub

Document last updated 2005-06-09 17:52:19 Printerfriendly version

User comments:

Ole P. from Norway wrote (2006-08-24 19:41:25 CET):

Re: Even though I tried hard, I was not able to use...
Click on the menu item "VBA Programming" in the menu to the left and read the document "How to use the macro examples".

Sur from Bombay wrote (2006-08-24 18:45:59 CET):

Even though I tried hard, I was not able to use the "compare two worksheet s in a single workbook"
Please help me with practical working. I donot know what to write in after = sign in excel cell to get the desired result. SInce, i am from finance background, it is crunchy for me.
Any one can help with the excel file. my mail ID is sur1981@gmail.com

Ole P. from Norway wrote (2005-08-24 09:30:52 CET):

Re: how to compare 2 worksheets in same workbook with id
See your alternatives for free support here.

Anthony from Spore wrote (2005-08-24 04:32:04 CET):

how to compare 2 worksheets in same workbook with id
i found the problem use your code if my worksheets record not in the same column and row ,ex: there's so many new inserting record manually with randomly ,so acctually the records that we want to compare is match but bcause it is not in the same row and column it's appear not match
so i think we can solve this probs by refering the search method use the unique key(id)

can u help me sir

Majsen from Corning, NY, USA wrote (2005-08-03 23:27:58 CET):

Re: one more question
Thanks a great bunch!!!

Ole P. from Norway wrote (2005-08-03 22:20:54 CET):

Re: one more question
If you can't remove the necessary code, you can remove the result like this:
Edit these three lines by adding a comment mark in front of two of them:
'If DiffCount = 0 Then
rptWB.Close False
'End If

Majsen from Corning, NY, USA wrote (2005-08-03 17:33:39 CET):

appologize, but one more question
I am trying to remove the code for which creates the new workbook with all the changes, but I can't seem to get it to work. Simply speaking I just want the compare and copy of changes, and the message box which tells me how many changes I have done.

Majsen from Corning, NY, USA wrote (2005-08-03 16:20:19 CET):

Re: Great stuff, but additional question
Thanks a bunch, that works perfect!

Ole P. from Norway wrote (2005-08-03 11:50:21 CET):

Re: Great stuff, but additional question
After this line:
Cells(r, c).Formula = "'" & cf1 & " " & cf2
Add this line:
ws2.Cells(r, c).FormulaLocal = cf1

Majsen from Corning, NY, USA wrote (2005-08-02 23:15:44 CET):

Great stuff, but additional question
This almost precisely what I am trying to do. I want to compare two worksheets, of which one is a master (ws1) and any changes in that one must be reflected in ws2. For example if the value in cell b45 in ws1 has changed, then it should be changed to that value in ws2 in the exact same cell. I don't seem to get it to work. Help, greatly appreciated.