Compare two workbooks and highlight the differences in the third workbook

[itsme2216]

I have created a macro which compares all the sheets of my Workbook1 with the sheets of Workbook2 and highlight the differences in the third workbook (sheet by sheet)
I have categorized the differences into different headers Like:-
List
Entered Value Changed.- Text When Value/Text is replaced by text/value
Value Mismatch Value replaced by incorrect value
Text Mismatch Value replaced by incorrect text
Incorrect Formula Formula replaced by different formula
Formula Deleted Formula is deleted
Formula Embedded Formula added
Value Deleted Missing Value
Value Added New Value is added
Now my problem is Currently, while comparing the two workbooks if the any of the value is deleted from any sheet of Workbook2 then while comparing it with Workbook1 it is categorizing under "Entered Value Changed.- Text" but I want it to come under "Value Deleted"
and second issue is Currently, while comparing the two workbooks if the any of the value is added from any sheet of Workbook2 then while comparing it with Workbook1 it is categorizing under "Entered Value Changed.- Text" but I want it to come under "Value Added"
I guess the below two lines needs to be modified:
<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">If TypeName(R2.Value) = "" Then
NoteError R1.Address, "Value Deleted", R1.Value, "**Missing Value**"

If TypeName(R1.Value) = "" Then
NoteError R1.Address, "Value Added", "**Missing Value**", R2.Value



Overall Code:-

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">Sub ExCompare()
Dim WS As Worksheet
Workbooks.Add
For Each WS In Workbooks("Solution_Project.xlsx").Worksheets
Call CompareWorkbooks(WS, Workbooks("Template_Project .xlsx").Worksheets(WS.Name))
Next
End Sub

Sub CompareWorkbooks(ByVal WS1 As Worksheet, ByVal WS2 As Worksheet)
Dim iRow As Integer
Dim iCol As Integer
Dim R1 As Range
Dim R2 As Range

Worksheets.Add.Name = WS1.Name ' new book for the results
Range("A1:D1").Value = Array("Address", "Difference", WS1.Parent.Name, WS2.Parent.Name)
Range("A2").Select
For iRow = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Row, _
WS2.Range("A1").SpecialCells(xlLastCell).Row)
For iCol = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Column, _
WS2.Range("A1").SpecialCells(xlLastCell).Column)

Set R1 = WS1.Cells(iRow, iCol)
Set R2 = WS2.Cells(iRow, iCol)

' compare the types to avoid getting VBA type mismatch errors.
If TypeName(R1.Value) <> TypeName(R2.Value) Then
NoteError R1.Address, "Entered Value Changed.- Text", R1.Value, R2.Value
ElseIf R1.Value <> R2.Value Then
If TypeName(R1.Value) = "Double" Then
If Abs(R1.Value - R2.Value) > R1.Value * 10 ^ (-12) Then
NoteError R1.Address, "Value Mismatch", R1.Value, R2.Value
End If
Else
NoteError R1.Address, "Text Mismatch", R1.Value, R2.Value
End If
If TypeName(R2.Value) = "" Then
NoteError R1.Address, "Value Deleted", R1.Value, "**Missing Value**"
End If
If TypeName(R1.Value) = "" Then
NoteError R1.Address, "Value Added", "**Missing Value**", R2.Value
End If
End If

' record formula without leading "=" to avoid them being evaluated
If R1.HasFormula Then
If R2.HasFormula Then
If R1.Formula <> R2.Formula Then
NoteError R1.Address, "Incorrect Formula", Mid(R1.Formula, 2), Mid(R2.Formula, 2)
End If
Else
NoteError R1.Address, "Formula Deleted", Mid(R1.Formula, 2), "**no formula**"
End If
Else
If R2.HasFormula Then
NoteError R1.Address, "Formula Embedded", "**no formula**", Mid(R2.Formula, 2)
End If
End If
If R1.NumberFormat <> R2.NumberFormat Then
NoteError R1.Address, "NumberFormat", R1.NumberFormat, R2.NumberFormat
End If
Next iCol
Next iRow
With ActiveSheet.UsedRange.Columns
.AutoFit
.HorizontalAlignment = xlLeft
End With
End Sub

Sub NoteError(Address As String, What As String, V1, V2)
ActiveCell.Resize(1, 4).Value = Array(Address, What, V1, V2)
ActiveCell.Offset(1, 0).Select
If ActiveCell.Row = Rows.Count Then
MsgBox "Too many differences", vbExclamation
End
End If
End Sub</code></code></pre>

 

[itsme2216]

Please suggest how to modify this code