Sub CompareSheets2()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Written by JoeMo 10/25/2010
'Compares 2 worksheets in same workbook to see if Sheet2 differs from Sheet1
'If sheet2 has a different usedrange than sheet1, the user has the option
'of exiting the sub or comparing only the usedrange of sheet1 to the same range in sheet2.
'If there are merged cells in either sheet, the cells are unmerged to make a comparison.
'This is necessary because in using Range.SpecialCells(xlCellTypeBlanks)on
'cells in Sheet1, VBA will include all merged cells in Range, even if they are not empty.
'After all comparisons are made, the cells that were unmerged are merged again
'to restore the original state of merged cells on both sheets.
'Any differences found in sht2 are given a cell fill with a color specific to the cell
'contents (i.e., error value, formula, constant, cell comment, ...).
'IF CELL COMMENTS ARE EDITED IN SHEET2 (i.e. changed from sheet1), THEY WILL BE
'DETECTED. HOWEVER, IF NEW COMMENTS ARE ADDED TO SHEET2, THE CELLS CONTAINING THEM
'WILL NOT BE IDENTIFIED (not worth the effort since added comments do not change
'the functionality of the sheet)EXCEPT TO SIGNAL IF THE TOTAL CELL COMMENT
'COUNT ON SHEET2 DIFFERS FROM THE TOTAL CELL COMMENT COUNT ON SHEET1.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim sht1 As Worksheet, sht2 As Worksheet, S1 As String, S2 As String
Dim rng1 As Range, rng2 As Range
Dim rng1b As Range, rng1e As Range, rng1f As Range
Dim rng1c As Range, rng1n As Range
Dim mRng1() As Range, mRng2() As Range, mR1 As Long, mR2 As Long, delta As Long
Dim N1 As Long, N2 As Long
Dim Adr1 As String, Adr2 As String
Dim Answer As Integer, msg As String
Dim DiffListB As String, DiffListE As String, DiffListF As String
Dim DiffListC As String, DiffListM As String, DiffListN As String, co As String
Dim mergedCels As Boolean, M1 As Boolean, M2 As Boolean
Dim calcState As Integer
S1 = InputBox("Enter the sheet name of the reference sheet that will be the base for comparison.")
If S1 = "" Then Exit Sub 'Cancel was clicked
S2 = InputBox("Enter the sheet name that you want to compare to " & S1 & ".")
If S2 = "" Then Exit Sub 'Cancel was clicked
Set sht1 = ActiveWorkbook.Sheets(S1)
Set sht2 = ActiveWorkbook.Sheets(S2)
Set rng1 = sht1.UsedRange
Set rng2 = sht2.UsedRange
Adr1 = rng1.Address
Adr2 = rng2.Address
'Compare Used Ranges
If Adr1 <> Adr2 Then
msg = sht2.Name & " covers range " & Adr2 & " while " & sht1.Name & " covers range " & Adr1
msg = msg & vbCrLf & vbCrLf & "Do you want to check for differences in cells within the usedrange of " & sht1.Name
Answer = MsgBox(msg, vbYesNo)
If Answer = vbNo Then Exit Sub
End If
'Check for merged cells
M1 = HasMergedCells(rng1)
M2 = HasMergedCells(rng2)
If M1 = M2 Then
Select Case M1
Case True: MsgBox "Both sheets have merged cells.": mergedCels = True
Case False: MsgBox "Neither sheet has merged cells.": mergedCels = False
End Select
Else
Select Case M1
Case True: MsgBox sht1.Name & " has merged cells while " & sht2.Name & " has none.": mergedCels = True
Case False: MsgBox sht1.Name & " has no merged cells while " & sht2.Name & " has merged cells.": mergedCels = True
End Select
End If
calcState = Application.Calculation
Application.Calculation = xlCalculationManual
'Unmerge any merged cells to make cell by cell comparison; restore merges later
'Also make merged cells comparison
If mergedCels Then
DiffListM = ""
Application.StatusBar = "UNMERGING MERGED CELLS TO ALLOW COMPARISON- THIS MAY TAKE AWHILE"
For Each cel In rng1
If cel.MergeCells Then
mR1 = mR1 + 1
ReDim Preserve mRng1(1 To mR1)
Set mRng1(mR1) = cel.MergeArea
If Not sht2.Range(mRng1(mR1).Address).MergeCells Then
sht2.Range(mRng1(mR1).Address).Interior.ColorIndex = 45
DiffListM = DiffListM & ", " & mRng1(mR1).Address
End If
End If
Next cel
Application.ScreenUpdating = False
For Each cel In rng2
If cel.MergeCells Then
mR2 = mR2 + 1
ReDim Preserve mRng2(1 To mR2)
Set mRng2(mR2) = cel.MergeArea
If Not sht1.Range(mRng2(mR2).Address).MergeCells Then
mRng2(mR2).Interior.ColorIndex = 45
DiffListM = DiffListM & ", " & mRng2(mR2).Address
End If
End If
Next cel
If M1 And M2 Then
delta = UBound(mRng1) - UBound(mRng2)
ElseIf M1 And Not M2 Then
delta = UBound(mRng1)
ElseIf Not M1 And M2 Then
delta = -UBound(mRng2)
End If
Select Case delta
Case 0: MsgBox "Same merged cells count in both sheets!"
Case Is > 0: MsgBox delta & " more merged cells in " & sht1.Name & " than in " & sht2.Name
Case Is < 0: MsgBox Abs(delta) & " fewer merged cells in " & sht1.Name & " than in " & sht2.Name
End Select
If Not DiffListM = "" Then
msg = "The following cells in " & sht2.Name & " are either not merged like their counterparts in " & sht1.Name _
& " or are merged unlike their counterparts in " & sht1.Name & ":" & vbNewLine
msg = msg & Right(DiffListM, Len(DiffListM) - 1) & vbNewLine & "These cells are highlighted with an orange fill."
End If
rng1.MergeCells = False
rng2.MergeCells = False
Application.ScreenUpdating = True
Application.StatusBar = False
End If
'
'Compare Error values
DiffListE = ""
On Error Resume Next
Set rng1e = rng1.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rng1e Is Nothing Then
For Each cel In rng1e
Adr1 = cel.Address
If Not IsError(sht2.Range(Adr1)) Then
sht2.Range(Adr1).Interior.ColorIndex = 8
DiffListE = DiffListE & ", " & Adr1
ElseIf CVErr(cel) <> CVErr(sht2.Range(Adr1)) Then
sht2.Range(Adr1).Interior.ColorIndex = 8
DiffListE = DiffListE & ", " & Adr1
End If
Next cel
End If
If rng1e Is Nothing Then
MsgBox "No error values found in " & sht1.Name
ElseIf DiffListE = "" Then
MsgBox "No differences in error values found!"
Else
msg = "Values in the following cells in " & sht2.Name & " differ from error values in the cells with the same address in " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListE, Len(DiffListE) - 1) & vbNewLine & "These cells are highlighted with a cyan fill."
End If
'Blank Cells in sheet1
On Error Resume Next
Set rng1b = rng1.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng1b Is Nothing Then
For Each cel In rng1b
Adr1 = cel.Address
If Not IsEmpty(sht2.Range(Adr1)) Then
sht2.Range(Adr1).Interior.ColorIndex = 4
DiffListB = DiffListB & ", " & Adr1
End If
Next cel
End If
If DiffListB = "" Then
MsgBox "No differences found in blank cells!"
Else
msg = "The following cells in " & sht2.Name & " are not blank like the same cells in " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListB, Len(DiffListB) - 1) & vbNewLine & "These cells are highlighted with a green fill."
End If
'Cells with comments (notes)
N1 = sht1.Comments.Count
N2 = sht2.Comments.Count
If N1 > 0 Or N2 > 0 Then
Select Case N1 - N2
Case Is > 0: MsgBox sht1.Name & " has " & N1 - N2 & " more cells with comments than " & sht2.Name
Case Is < 0: MsgBox sht1.Name & " has " & N2 - N1 & " fewer cells with comments than " & sht2.Name
End Select
DiffListN = ""
On Error Resume Next
Set rng1n = rng1.SpecialCells(xlCellTypeComments)
On Error GoTo 0
If Not rng1n Is Nothing Then
For Each cel In rng1n
Adr1 = cel.Address
On Error Resume Next
co = sht2.Range(Adr1).Comment.Text
If Err.Number = 0 Then
If cel.Comment.Text <> co Then
sht2.Range(Adr1).Interior.ColorIndex = 17
DiffListN = DiffListN & ", " & Adr1
End If
Else 'No comment in the cell in sht2
sht2.Range(Adr1).Interior.ColorIndex = 17
DiffListN = DiffListN & ", " & Adr1
End If
On Error GoTo 0
Next cel
End If
If DiffListN = "" Then
MsgBox "No differences found in cells with Comments (Notes)!"
Else
msg = "The following cells in " & sht2.Name & " differ with respect to cell comments from the cells with the same address in " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListN, Len(DiffListN) - 1) & vbNewLine & "These cells are highlighted with a purple fill."
End If
End If
'Formula Cells - only looks at formula cells in sht1. sht2 formulas
'not in sht1 will not be detected here unless they occupy a cell
'that is empty in sht1 or has a different value in sht1.
DiffListF = ""
On Error Resume Next
Set rng1f = rng1.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng1f Is Nothing Then
For Each cel In rng1f
Adr1 = cel.Address
If cel.Formula <> sht2.Range(Adr1).Formula Then
sht2.Range(Adr1).Interior.ColorIndex = 6
DiffListF = DiffListF & ", " & Adr1
End If
Next cel
End If
If DiffListF = "" Then
MsgBox "No differences found in cells with formulas!"
Else
msg = "Formulas in the following cells in " & sht2.Name & " differ from formulas in the cells with the same address in " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListF, Len(DiffListF) - 1) & vbNewLine & "These cells are highlighted with a yellow fill."
End If
'Numbers, Text,logical values cells
DiffListC = ""
On Error Resume Next
Set rng1c = rng1.SpecialCells(xlCellTypeConstants, 7)
On Error GoTo 0
If Not rng1c Is Nothing Then
For Each cel In rng1c
Adr1 = cel.Address
If Not IsError(sht2.Range(Adr1)) Then
If cel.Formula <> sht2.Range(Adr1).Formula Then 'use Formula instead of Value to detect cases where there is a constant in sht1 and a formula in sht2 that produces the sht1 value
sht2.Range(Adr1).Interior.ColorIndex = 3
DiffListC = DiffListC & ", " & Adr1
End If
Else
sht2.Range(Adr1).Interior.ColorIndex = 7
DiffListC = DiffListC & ", " & Adr1
End If
Next cel
End If
If DiffListC = "" Then
MsgBox "No differences found in cells with constants or logical values!"
Else
msg = "The following cells in " & sht2.Name & " differ in value and/or there is a formula in " & sht2.Name
msg = msg & " that is not present in " & sht1.Name & ":"
MsgBox msg & vbNewLine & Right(DiffListC, Len(DiffListC) - 1) & vbNewLine & "These cells are highlighted with a magenta fill if they contain an error value, and a red fill otherwise."
End If
'Reset any cells that originally were merged
Application.ScreenUpdating = False
If mergedCels Then
If M1 Then
For i = 1 To UBound(mRng1)
mRng1(i).Merge
Next i
End If
If M2 Then
For i = 1 To UBound(mRng2)
mRng2(i).Merge
Next i
End If
End If
MsgBox "Comparison of " & sht2.Name & " to " & sht1.Name & " has completed."
Application.ScreenUpdating = True
Application.Calculation = calcState
End Sub
Function HasMergedCells(rng As Range) As Boolean
HasMergedCells = False
For Each c In rng
If c.MergeCells Then
HasMergedCells = True
Exit Function
End If
Next c
End Function
). The code you posted nearly works, and I can see what it is doing. For each cell that is the same as the Before sheet, it is copying the entire row, so for to the 10 columns I get 10 copies of the same row. I think I'll have to rethink of how the loop works, thanks again for he help.
