Compare Two ex cel sheets and highlight differences

[neerukonda9]

Hi Saket

Thank you for the reply. Unfortunately I didn't pick up where to amend the code. I tried different combinations resulting in different errors. Appreciate if you could amend the below code with the previous input.

My apologies for being painful
many thanks
maruti
---------------------------------

Code:

Function excel_comp_threedec

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
ObjExcel.displayAlerts = False

Set objWorkbook2= objExcel.Workbooks.Open(expectedfile)

Set objWorkbook1= objExcel.Workbooks.Open(actualfile)

'objWorkbook1.SaveAs DifferenceFile

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
    cell.Select
    If cell.value <> "" Then
                If instr(1,cell.value,".") Then
                            iPos= instr(1,cell.value,".")+1
                            If mid(cell.Value,iPos,4) <> mid(objWorksheet2.Range(cell.Address).Value,iPos,4) Then
                                    cell.Interior.ColorIndex = 6 'Highlights in red color if any changes in cells
                                    ObjExcel.displayAlerts = False
                                    objWorkbook1.Save
                            end if
                else
                            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
                            Else
                                    cell.Interior.ColorIndex = 0
                            End If
                End If
    End If

Next

Next

objExcel.Save

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

End if
next
Set objExcel=Nothing

end function

-----------------------------------------------------------------