Hi All, need urgent help please.
 

Hi everyone,

I need to compare each cell in a sheet on workbook 1 to the same cell on
workbook 2 in terms of value/formula and highlight any differences. I have
about 62 workbooks to compare which would take weeks, so I was hoping
someone could give me some code to do this?

I'd be eternally gratefull!

TIA

FD

Hi All, need urgent help please.
 

Hi FD

This raises a couple of questions:
Are you comparing all the books against a 'master' copy or each book against
all 61 other books?
Is there a set range of cells in each book that you want to check or is it
variable?

The code below will compare specific sheets and list the results.

********
Option Explicit

Public Sub CompareBooks()

Dim rngOutput As Range
Dim wksSheet1 As Worksheet
Dim wksSheet2 As Worksheet

Set rngOutput = ThisWorkbook.Worksheets("Sheet1").Range("A1")
'clear previous results
rngOutput.CurrentRegion.ClearContents

Set wksSheet1 = Workbooks("Test1.xls").Worksheets("Sheet1")
Set wksSheet2 = Workbooks("Test2.xls").Worksheets("Sheet1")

If CompareSheets(wksSheet1, wksSheet2, rngOutput) = False Then
MsgBox "Sheets did not match!", vbInformation
Else
MsgBox "Finished. All ok", vbInformation
End If

CleanUp:
If Not (wksSheet1 Is Nothing) Then Set wksSheet1 = Nothing
If Not (wksSheet2 Is Nothing) Then Set wksSheet2 = Nothing
If Not (rngOutput Is Nothing) Then Set rngOutput = Nothing

End Sub
Private Function CompareSheets(ByRef pwksSheet1 As Worksheet, pwksSheet2 As
Worksheet, _
ByRef prngOutput As Range) As Boolean
' uses the SpecialCells method to get the xlCellTypeLastCell range on
pwksSheet1 and pwksSheet2
' checks that this gives the same range on sheets
' then loops through all the cells up to & including that cell
' comparing the value, number format and the colorindex

Dim rngLastCellSheet1 As Range
Dim rngCurrentCellSheet1 As Range
Dim rngLastCellSheet2 As Range
Dim rngCurrentCellSheet2 As Range
Dim rngCellsSheet1 As Range
Dim rngCellsSheet2 As Range
Dim blnCellsMatch As Boolean

Const PROC_NAME As String = "CompareSheets"

blnCellsMatch = True

' If sheets are protected then unprotect them
' Sheets must be unprotected to use the SpecialCells method
If pwksSheet1.ProtectContents Then
Call UnprotectSheet(pwksSheet1)
End If
If pwksSheet2.ProtectContents Then
Call UnprotectSheet(pwksSheet2)
End If

Set rngLastCellSheet1 = pwksSheet1.Cells.SpecialCells(xlCellTypeLastCell)
Set rngLastCellSheet2 = pwksSheet2.Cells.SpecialCells(xlCellTypeLastCell)
' are the last cells the same address?
If rngLastCellSheet1.Address = rngLastCellSheet2.Address Then
' addresses are the same so check each cell
Set rngCellsSheet1 =
pwksSheet1.Range("A1").Resize(RowSize:=rngLastCell Sheet1.Row,
ColumnSize:=rngLastCellSheet1.Column)
For Each rngCurrentCellSheet1 In rngCellsSheet1.Cells
Set rngCurrentCellSheet2 =
pwksSheet2.Range(rngCurrentCellSheet1.Address)
If Not TwoCellsCompareOk(rngCurrentCellSheet1,
rngCurrentCellSheet2, prngOutput) Then
blnCellsMatch = False
End If
Next rngCurrentCellSheet1
Else
blnCellsMatch = False
' addresses are NOT the same
Call WriteToOutput(prngOutput, pwksSheet1.Parent.Name,
pwksSheet2.Parent.Name, _
"The range xlCellTypeLastCell gives different cells: " &
pwksSheet1.Name & "!" & rngLastCellSheet1.Address _
& " vs " & pwksSheet2.Name & "!" & rngLastCellSheet2.Address)
End If

CleanUp:
CompareSheets = blnCellsMatch
Exit Function

End Function
Private Function TwoCellsCompareOk(ByRef prngFirstCell As Range,
prngSecondCell As Range, _
ByRef prngOutput As Range) As Boolean
' compares the two cells to see if contents and some formatting is the same

Dim strFirstBook As String
Dim strSecondBook As String
Dim strSheetName As String
Dim blnCellsMatch As Boolean

Const PROC_NAME As String = "TwoCellsCompareOk"

blnCellsMatch = True
strFirstBook = prngFirstCell.Parent.Parent.Name
strSecondBook = prngSecondCell.Parent.Parent.Name
' Both cells are on identically named worksheets
strSheetName = prngFirstCell.Parent.Name

' Formula
If prngFirstCell.Formula < prngSecondCell.Formula Then
blnCellsMatch = False
Call WriteToOutput(prngOutput, strFirstBook, strSecondBook, _
"The Formulae in cell " & strSheetName & "!" &
prngFirstCell.Address & " do not match: " _
& prngFirstCell.Formula & " vs " & prngSecondCell.Formula)
End If

' NumberFormat
If prngFirstCell.NumberFormat < prngSecondCell.NumberFormat Then
blnCellsMatch = False
Call WriteToOutput(prngOutput, strFirstBook, strSecondBook, _
"The NumberFormats in cell " & strSheetName & "!" &
prngFirstCell.Address & " do not match: " _
& prngFirstCell.NumberFormat & " vs " &
prngSecondCell.NumberFormat)
End If

'ColorIndex
If prngFirstCell.Interior.ColorIndex <
prngSecondCell.Interior.ColorIndex Then
blnCellsMatch = False
Call WriteToOutput(prngOutput, strFirstBook, strSecondBook, _
"The ColorIndexes in cell " & strSheetName & "!" &
prngFirstCell.Address & " do not match: " _
& prngFirstCell.Interior.ColorIndex & " vs " &
prngSecondCell.Interior.ColorIndex)
End If

CleanUp:
TwoCellsCompareOk = blnCellsMatch
Exit Function

End Function
Private Sub UnprotectSheet(ByRef pwksSheet As Worksheet)

pwksSheet.Unprotect

End Sub
Private Sub WriteToOutput(ByRef prngOutput As Range, _
pstrFirstBook As String, pstrSecondBook As String, pstrText As String)

With prngOutput
.Offset(ColumnOffset:=0).Value = pstrFirstBook
.Offset(ColumnOffset:=1).Value = pstrSecondBook
.Offset(ColumnOffset:=2).Value = pstrText
End With
Set prngOutput = prngOutput.Offset(RowOffset:=1)

End Sub

********

--
HTH

Simon


"FrigidDigit" wrote:

Hi everyone,

I need to compare each cell in a sheet on workbook 1 to the same cell on
workbook 2 in terms of value/formula and highlight any differences. I have
about 62 workbooks to compare which would take weeks, so I was hoping
someone could give me some code to do this?

I'd be eternally gratefull!

TIA

FD

Hi All, need urgent help please.
 

Hi Simon,

Thanks so much for the response!!

I am comparing the books in pairs, so each book will be checked against its
one "partner".

The range to check is identical for all workbooks.

Sorry I took so long to respond, was having problems with my isp.

I am working through the code you gave me as I am sure it will come in very
handy!

Thanks again

FD

"Simon Letten" wrote in message
...
Hi FD

This raises a couple of questions:
Are you comparing all the books against a 'master' copy or each book
against
all 61 other books?
Is there a set range of cells in each book that you want to check or is it
variable?

The code below will compare specific sheets and list the results.

********
Option Explicit

Public Sub CompareBooks()

Dim rngOutput As Range
Dim wksSheet1 As Worksheet
Dim wksSheet2 As Worksheet

Set rngOutput = ThisWorkbook.Worksheets("Sheet1").Range("A1")
'clear previous results
rngOutput.CurrentRegion.ClearContents

Set wksSheet1 = Workbooks("Test1.xls").Worksheets("Sheet1")
Set wksSheet2 = Workbooks("Test2.xls").Worksheets("Sheet1")

If CompareSheets(wksSheet1, wksSheet2, rngOutput) = False Then
MsgBox "Sheets did not match!", vbInformation
Else
MsgBox "Finished. All ok", vbInformation
End If

CleanUp:
If Not (wksSheet1 Is Nothing) Then Set wksSheet1 = Nothing
If Not (wksSheet2 Is Nothing) Then Set wksSheet2 = Nothing
If Not (rngOutput Is Nothing) Then Set rngOutput = Nothing

End Sub
Private Function CompareSheets(ByRef pwksSheet1 As Worksheet, pwksSheet2
As
Worksheet, _
ByRef prngOutput As Range) As Boolean
' uses the SpecialCells method to get the xlCellTypeLastCell range on
pwksSheet1 and pwksSheet2
' checks that this gives the same range on sheets
' then loops through all the cells up to & including that cell
' comparing the value, number format and the colorindex

Dim rngLastCellSheet1 As Range
Dim rngCurrentCellSheet1 As Range
Dim rngLastCellSheet2 As Range
Dim rngCurrentCellSheet2 As Range
Dim rngCellsSheet1 As Range
Dim rngCellsSheet2 As Range
Dim blnCellsMatch As Boolean

Const PROC_NAME As String = "CompareSheets"

blnCellsMatch = True

' If sheets are protected then unprotect them
' Sheets must be unprotected to use the SpecialCells method
If pwksSheet1.ProtectContents Then
Call UnprotectSheet(pwksSheet1)
End If
If pwksSheet2.ProtectContents Then
Call UnprotectSheet(pwksSheet2)
End If

Set rngLastCellSheet1 =
pwksSheet1.Cells.SpecialCells(xlCellTypeLastCell)
Set rngLastCellSheet2 =
pwksSheet2.Cells.SpecialCells(xlCellTypeLastCell)
' are the last cells the same address?
If rngLastCellSheet1.Address = rngLastCellSheet2.Address Then
' addresses are the same so check each cell
Set rngCellsSheet1 =
pwksSheet1.Range("A1").Resize(RowSize:=rngLastCell Sheet1.Row,
ColumnSize:=rngLastCellSheet1.Column)
For Each rngCurrentCellSheet1 In rngCellsSheet1.Cells
Set rngCurrentCellSheet2 =
pwksSheet2.Range(rngCurrentCellSheet1.Address)
If Not TwoCellsCompareOk(rngCurrentCellSheet1,
rngCurrentCellSheet2, prngOutput) Then
blnCellsMatch = False
End If
Next rngCurrentCellSheet1
Else
blnCellsMatch = False
' addresses are NOT the same
Call WriteToOutput(prngOutput, pwksSheet1.Parent.Name,
pwksSheet2.Parent.Name, _
"The range xlCellTypeLastCell gives different cells: " &
pwksSheet1.Name & "!" & rngLastCellSheet1.Address _
& " vs " & pwksSheet2.Name & "!" &
rngLastCellSheet2.Address)
End If

CleanUp:
CompareSheets = blnCellsMatch
Exit Function

End Function
Private Function TwoCellsCompareOk(ByRef prngFirstCell As Range,
prngSecondCell As Range, _
ByRef prngOutput As Range) As Boolean
' compares the two cells to see if contents and some formatting is the
same

Dim strFirstBook As String
Dim strSecondBook As String
Dim strSheetName As String
Dim blnCellsMatch As Boolean

Const PROC_NAME As String = "TwoCellsCompareOk"

blnCellsMatch = True
strFirstBook = prngFirstCell.Parent.Parent.Name
strSecondBook = prngSecondCell.Parent.Parent.Name
' Both cells are on identically named worksheets
strSheetName = prngFirstCell.Parent.Name

' Formula
If prngFirstCell.Formula < prngSecondCell.Formula Then
blnCellsMatch = False
Call WriteToOutput(prngOutput, strFirstBook, strSecondBook, _
"The Formulae in cell " & strSheetName & "!" &
prngFirstCell.Address & " do not match: " _
& prngFirstCell.Formula & " vs " & prngSecondCell.Formula)
End If

' NumberFormat
If prngFirstCell.NumberFormat < prngSecondCell.NumberFormat Then
blnCellsMatch = False
Call WriteToOutput(prngOutput, strFirstBook, strSecondBook, _
"The NumberFormats in cell " & strSheetName & "!" &
prngFirstCell.Address & " do not match: " _
& prngFirstCell.NumberFormat & " vs " &
prngSecondCell.NumberFormat)
End If

'ColorIndex
If prngFirstCell.Interior.ColorIndex <
prngSecondCell.Interior.ColorIndex Then
blnCellsMatch = False
Call WriteToOutput(prngOutput, strFirstBook, strSecondBook, _
"The ColorIndexes in cell " & strSheetName & "!" &
prngFirstCell.Address & " do not match: " _
& prngFirstCell.Interior.ColorIndex & " vs " &
prngSecondCell.Interior.ColorIndex)
End If

CleanUp:
TwoCellsCompareOk = blnCellsMatch
Exit Function

End Function
Private Sub UnprotectSheet(ByRef pwksSheet As Worksheet)

pwksSheet.Unprotect

End Sub
Private Sub WriteToOutput(ByRef prngOutput As Range, _
pstrFirstBook As String, pstrSecondBook As String, pstrText As String)

With prngOutput
.Offset(ColumnOffset:=0).Value = pstrFirstBook
.Offset(ColumnOffset:=1).Value = pstrSecondBook
.Offset(ColumnOffset:=2).Value = pstrText
End With
Set prngOutput = prngOutput.Offset(RowOffset:=1)

End Sub

********

--
HTH

Simon


"FrigidDigit" wrote:

Hi everyone,

I need to compare each cell in a sheet on workbook 1 to the same cell on
workbook 2 in terms of value/formula and highlight any differences. I
have
about 62 workbooks to compare which would take weeks, so I was hoping
someone could give me some code to do this?

I'd be eternally gratefull!

TIA

FD