Compare Two ex cel sheets and highlight differences

[vijaychourasiya0109@gmail.com]

Guys

I am looking at upgrading the below script for comparing two excel sheets in a way that the differences will be highlightled only when the data in the cells differ after three decimal places.

example: cell 1 --- 3.00123; cell 2--- 3.00132

I don't want to hightlight the above difference as there is no difference upto three decimals.

Any quick response is much appreciated.

many thanks in advance.


I am looking at upgrading the

Code:

Function excel_comp

expectedfolder = environment("expfld")

actualfolder = environment("actfld")

difffolder = environment("difffld")

Dim fso, f, fc, f1

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.GetFolder(expectedfolder)

Set fc = f.Files

For Each f1 in fc

expectedfile = expectedfolder + f1.name
actualfile = actualfolder + replace(f1.Name,".xls","a.xls")

Set WSShell = CreateObject("WScript.shell")

Set objExcel = CreateObject("Excel.Application")

objExcel.Visible = false

Set objWorkbook2= objExcel.Workbooks.Open(expectedfile)

Set objWorkbook1= objExcel.Workbooks.Open(actualfile)

WScount1=objWorkbook1.Worksheets.Count
WScount2=objWorkbook2.Worksheets.Count

If WScount1<>WScount2 Then
WSShell.Popup "Number of worksheets in file 1 is not equal to Number of worksheets in file 2", 2

Else
For I = 1 To WScount1
Set objWorksheet1= objWorkbook1.Worksheets(I)
Set objWorksheet2= objWorkbook2.Worksheets(I)

For Each cell In objWorksheet1.UsedRange
If cell.Value <> objWorksheet2.Range(cell.Address).Value Then
cell.Interior.ColorIndex = 6 'Highlights in red color if any changes in cells
ObjExcel.displayAlerts = False
objWorkbook1.SaveAs difffolder + f1.name
objExcel.Save

Else
cell.Interior.ColorIndex = 0
End If
Next

Next
ObjExcel.displayAlerts = False
objExcel.Save

Set objWorksheet1= Nothing
Set objWorksheet2= Nothing
objExcel.Application.Quit

End if
next
Set objExcel=Nothing

end function

Set objMyExcel = CreateObject("Excel.Application")
objMyExcel.Visible = False

Set objMyDataExcel1= objMyExcel.Workbooks.Open("C:\Users\chourasiyav\Desktop\sample\File 2.xlsx")
Set objMyDataExcel2= objMyExcel.Workbooks.Open("C:\Users\chourasiyav\Desktop\sample\File3.xlsx")

Set objMyWorksheet1= objMyDataExcel1.Worksheets(3)
Set objMyWorksheet2= objMyDataExcel2.Worksheets(3)

For Each cell In objMyWorksheet1.UsedRange

'if the found unique value/Unmatched value then hightlight row in the red color
   If cell.Value <> objMyWorksheet2.Range(cell.Address).Value Then
       objMyWorksheet2.Range(cell.Address).Value = cell.Value
       cell.Interior.ColorIndex = 3

   Else

       cell.Interior.ColorIndex = 0

   End If

 Next

Set objMyExcel = Nothing
objMyDataExcel1.SaveAs("C:\Users\chourasiyav\Desktop\sample\File4.xlsx")
wait 2
objMyDataExcel1.Close