itsme2216

05-17-2017, 09:33 PM

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:

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:-

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

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:

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:-

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