Compare two worksheets

 2005-06-09    Worksheets    6    71

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



Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.

OPE | 2017-04-12 21:44:22 (GMT)

If you get an "Subscript is out of range" error message, this is usually because the code can't find the specified worksheet or workbook.
Try changing the worksheet names "Sheet1" and "Sheet2" to the actual worksheet names in your workbook(s).

bashar | 2017-04-12 21:37:03 (GMT)

Not sure if this thread is still active. I tried the VBA on the bottom to compare all sheets from 2 workbooks but I can't get it to work. I copied the code as is and paste it into VB editor in Excel and it won't run saying "Subscript is out of range"? I tried the code where it compares the first sheets of 2 different workbooks and that one works fine. If you are still active, help would be greatly appreciated?

OPE | 2014-07-26 11:43:18 (GMT)

To copy rows with differences you can edit the macro CompareWorksheets and change this line:
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
To something like this that will copy the row with differences from the second worksheet:
ws2.Rows(r).Copy Cells(DiffCount, 1)

Gary | 2014-07-17 01:50:14 (GMT)

Hi i am trying to compare two worksheets in one workbook. your code works really well but it copies the cell (which is not similar) into the new workbook. I don know anything about coding.
Can i have the complete row instead of just the cell in the new workbook ? so if G23 is different , instead of having just G23 can i have the row 23?

Thank you so much for your help.

OPE | 2009-07-22 10:11:48 (GMT)

The macros below should probably do most of what you are requesting.

Sub CompareAllWorksheets(wb1 As Workbook, wb2 As Workbook)
' compares all worksheets in wb1 with the worksheets in wb2
Dim wbResult As Workbook, i As Long, lngDiffCount As Long, t As Long
If wb1 Is Nothing Then Exit Sub
If wb2 Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Application.Cursor = xlWait
lngDiffCount = 0
For i = 1 To wb1.Worksheets.Count
If wb2.Worksheets.Count >= i Then
CompareWorksheets wbResult, wb1.Worksheets(i), wb2.Worksheets(i), t
lngDiffCount = lngDiffCount + t
End If
Next i
If lngDiffCount = 0 Then ' no differences
wbResult.Close False
End If
Application.Cursor = xlDefault
Application.ScreenUpdating = True
MsgBox lngDiffCount & " cells contain different formulas!", vbInformation, _
"Compare worksheets in " & wb1.Name & " with worksheets in " & wb2.Name
End Sub

Sub CompareWorksheets(wbTarget As Workbook, ws1 As Worksheet, _
ws2 As Worksheet, Optional lngDiffCount As Long = 0)
Dim r As Long, c As Integer, wsTarget As Worksheet
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
lngDiffCount = 0
If wbTarget Is Nothing Then ' create the report workbook
Application.StatusBar = "Creating the report workbook..."
Set wbTarget = Workbooks.Add
With wbTarget
Application.DisplayAlerts = False
Do While Worksheets.Count > 1
Worksheets(2).Delete
Loop
Application.DisplayAlerts = True
Set wsTarget = .Worksheets(.Worksheets.Count)
End With
Else ' add a new worksheet to the report workbook
With wbTarget
r = .Worksheets.Count
On Error Resume Next
.Worksheets.Add
On Error GoTo 0
If r < .Worksheets.Count Then
Set wsTarget = .Worksheets(.Worksheets.Count)
End If
End With
End If
If wsTarget Is Nothing Then Exit Sub

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
lngDiffCount = 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
lngDiffCount = lngDiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
End If
Next r
Next c

Application.StatusBar = "Formatting the report..."
With wsTarget.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
With wsTarget
On Error Resume Next
.Columns("A:IV").ColumnWidth = 20
.Range("A1").AddComment "Compare " & ws1.Name & _
" with " & ws2.Name & ":" & vbLf & _
lngDiffCount & " cells contain different formulas!"
On Error GoTo 0
End With
Set wsTarget = Nothing
Application.StatusBar = False
End Sub

Sub TestCompareAllWorksheets()
CompareAllWorksheets Workbooks("FirstWorkbook.xls"), Workbooks("SecondWorkbook.xls")
End Sub

Ariesto | 2009-07-21 22:48:04 (GMT)

Hi. I just spent all afternoon trying to expand your "compare two worksheets" macro to compare all worksheets within two workbooks. Good to see in this updated code you can now call the compareWorksheets() multiple times.

My problem, if you have time/interest, is that I want the results from the macro dumped into one workbook instead of creating a new workbook every time the function runs.

Imagine two workbooks with 90 identically named sheets and you can see the necessity of the results going into one workbook. I was also trying to add a summary page instead of the message box. I think I could add the summary page if your code was set up to create 1 workbook instead of 90 workbooks.

Thanks for any help you offer and for the excellent starting point.