Google Exceltip.com
Account Icon
Shopping Cart
CheckOut

» Compare two worksheets using VBA in Microsoft Excel

VBA macro tip contributed by Erlandsen Data Consulting offering Microsoft Excel Application development, template customization, support and training solutions
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
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
 
Rate this tip
12 34 5
  RATING: 3.49
  VIEWS: 112073
Very Benificial
Mukesh Singh wrote on December 31, 1969 19:00 EST
Very Useful.I changed few lines and it worked fine....
::::
:::
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
'Old Code:
'While Worksheets.Count > 1
' Worksheets(2).Delete
'Wend
'New Code:
While rptWB.Worksheets.Count > 1
rptWB .Worksheets(2).Delete
Wend

Application.DisplayAlerts = True
::::
::::
Very Benificial
Mukesh Singh wrote on December 31, 1969 19:00 EST
Very Useful.I changed few lines and it worked fine....
::::
:::
Set rptWB = Workbooks.Add
Application.DisplayAlerts = False
'Old Code:
'While Worksheets.Count > 1
' Worksheets(2).Delete
'Wend
'New Code:
While rptWB.Worksheets.Count > 1
rptWB .Worksheets(2).Delete
Wend

Application.DisplayAlerts = True
::::
::::
I do not know how to run that
pkadera@gmail.com wrote on December 31, 1969 19:00 EST
Guys, when I copy the macro into my workbook, it would not appear under Macros in THIS WORKBOOK. How would one run it? Thanks for your answers.
pk
comparing 2 workbooks
kendra whittington wrote on December 31, 1969 19:00 EST
i dont quite understand how to use the macro above. Could someone tell me how to do that.

thanks
kendra
wrote on December 31, 1969 19:00 EST
Very useful indeed....I changed a few lines too to highlight the differences in Red...
Urck wrote on December 31, 1969 19:00 EST
What if the number of lines change?



REGISTERED USERS click here to post comments


GUESTSclick here to Register
Name
Comment Title
Comments


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.

Copyright © 2003 ExcelTip.com
Microsoft, Microsoft Excel is a U.S. registered trademark of Microsoft Corporation