Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet, sheetname As String, count As Integer, rptWB As Workbook)
Dim r, counter, cellstotal 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 DiffCount As Long
Dim foundcell As Range, lastcell As Range, firstcell As Range, needle As String, spares As Integer
Dim spareflag As Boolean, diffflag As Boolean, strpos1 As Integer, strpos2 As Integer, filledflag1 As Boolean, filledflag2 As Boolean
Application.DisplayAlerts = True
'get number rows and columns from reference
With ws1.UsedRange
lr1 = .Rows.count
lc1 = .Columns.count
End With
'filter spares
needle = "spare"
spares = 0
With Range(Cells(10, 1), Cells(lr1, lc1))
Set lastcell = .Cells(.Cells.count)
End With
Set foundcell = ws1.Cells.Find(What:=needle, After:=Cells(10, 1), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If Not foundcell Is Nothing Then
firstaddr = foundcell.Address
spares = spares + 1
Do
Debug.Print foundcell.Address
Set foundcell = ws1.Cells.FindNext(After:=foundcell)
spares = spares + 1
Loop While Not foundcell Is Nothing And foundcell.Address <> firstaddr
End If
'MsgBox spares & " #spares"
'get number of cells for statusbar
If ws1.UsedRange.Cells.count > ws2.UsedRange.Cells.count Then
cellstotal = ws1.UsedRange.Cells.count
Else
cellstotal = ws2.UsedRange.Cells.count
End If
'get number rows and columns from target
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
counter = 0
For r = 9 To maxR
'Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
spareflag = False
diffflaf = False
For c = 1 To maxC
counter = counter + 1
Application.StatusBar = counter & "/" & cellstotal
Workbooks("Comparator.xlsm").Worksheets("Sheet1").ProgressBar1.Width = counter & "/" & cellstotal
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = UCase(ws1.Cells(r, c).FormulaLocal)
cf2 = UCase(ws2.Cells(r, c).FormulaLocal)
cf1o = ws1.Cells(r, c).FormulaLocal
cf2o = ws2.Cells(r, c).FormulaLocal
On Error GoTo 0
strpos1 = InStr(cf1, "SPARE")
strpos2 = InStr(cf2, "SPARE")
If IsEmpty(ws1.Cells(r, c)) = False Then
filledflag1 = True
End If
If IsEmpty(ws2.Cells(r, c)) = False Then
filledflag2 = True
End If
If strpos1 <> 0 Or strpos2 <> 0 Then
spareflag = True
End If
If cf1 <> cf2 Then
diffflag = True
DiffCount = DiffCount + 1
Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
End If
Cells(r, c).AddComment.Text Text:="Comparator:"
Next c
With Range(Cells(r, 1), Cells(r, maxC))
If filledflag1 = True And filledflag2 = False Then
.Interior.ColorIndex = 44
ElseIf filledflag1 = False And filledflag2 = True Then
.Interior.ColorIndex = 46
ElseIf spareflag = True Then
.Interior.ColorIndex = 8
ElseIf diffflag = True Then
.Interior.ColorIndex = 3
Else
.Interior.ColorIndex = 19
End If
End With
Next r
'format results
With Range(Cells(9, 1), Cells(maxR, maxC))
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
Set rptWB = Nothing
Workbooks("Compare.xlsx").Worksheets("Result_Summary").Cells(2 + count, 1).Formula = sheetname
Workbooks("Compare.xlsx").Worksheets("Result_Summary").Cells(2 + count, 2).Formula = DiffCount
Workbooks("Compare.xlsx").Worksheets("Result_Summary").Cells(2 + count, 3).Formula = spares
'MsgBox DiffCount & " cells contain different formulas!", vbInformation, _
' "Compare " & ws1.Name & " with " & ws2.Name
End Sub
