Option Explicit 
 
 ''===================================================================
 '' Program:     FindChanges
 '' Desc:        Given two workbooks (one original, one updated) in
 ''              the same directory location, with identical worksheet
 ''              names, this program finds and highlights all the
 ''              values in the updated sheet that are different from
 ''              those in original sheet.
 '' Called by:   [Button on spreadsheet]
 '' Call:        LastCell
 '' Changes----------------------------------------------
 '' Date         Programmer      Change
 '' 02/16/12     Alex M.         Written
 ''===================================================================
Sub FindChanges() 
    Dim wbkCtlPanel As Workbook 
    Dim wbkOrigFile As Workbook 
    Dim wbkUpdated As Workbook 
    Dim wrkCtlPanel As Worksheet 
    Dim wrkOrig As Worksheet 
    Dim wrkUpdate As Worksheet 
    Dim rngLastOrig As Range 
    Dim rngLastUpdate As Range 
    Dim FSO As FileSystemObject 
     
    Dim strFilepath As String 
    Dim strOrigFile As String 
    Dim strUpdated As String 
    Dim lngRowStart As Long 
    Dim lngColStart As Long 
    Dim lngPercent As Long 
    Dim N As Long 
    Dim Q As Long 
    Dim P As Long 
     
    Application.ScreenUpdating = False 
     
    Set wbkCtlPanel = ActiveWorkbook 
    Set wrkCtlPanel = wbkCtlPanel.Worksheets("Control Panel") 
     
     'get user-entered values for files and location
    With wrkCtlPanel 
        strFilepath = .Range("B4").Value 
        strOrigFile = .Range("B5").Value 
        strUpdated = .Range("B6").Value 
    End With 
     
     'the base path which has to be searched for Files
    Set FSO = New FileSystemObject 
     ''check if the folder actually exists or not
     
    If (Not (FSO.FolderExists(strFilepath))) Then 
         'the folder path is invalid. Exiting.
        MsgBox strFilepath & vbCrLf & "is an Invalid Path!" 
        Exit Sub 
    End If 
     
    Workbooks.Open strFilepath & "/" & strOrigFile 
    Set wbkOrigFile = Workbooks(strOrigFile) 
     
    Workbooks.Open strFilepath & "/" & strUpdated 
    Set wbkUpdated = Workbooks(strUpdated) 
     
    For Each wrkUpdate In wbkUpdated.Worksheets 
        On Error GoTo ErrorSheetAdded 
        Set wrkOrig = wbkOrigFile.Worksheets(wrkUpdate.Name) 
        On Error GoTo 0 
         
        Set rngLastOrig = LastCell(wrkOrig) 
        Set rngLastUpdate = LastCell(wrkUpdate) 
         
        lngRowStart = Application.WorksheetFunction.Max(rngLastOrig.Row, rngLastUpdate.Row) 
        lngColStart = Application.WorksheetFunction.Max(rngLastOrig.Column, rngLastUpdate.Column) 
         
        With wrkUpdate 
            For P = lngColStart To 1 Step -1 
                For Q = lngRowStart To 1 Step -1 
                    If .Cells(Q, P).Value <> vbNullString And _ 
                    wrkOrig.Cells(Q, P).Value <> vbNullString Then 
                         'calculate percent complete, based on "area" of the spreadsheet
                        lngPercent = (100 * ((lngColStart - P) * (lngRowStart - Q) / (lngColStart * lngRowStart))) 
                        Application.StatusBar = "Checking updated sheet " & wrkUpdate.Name & _ 
                        " for changes..." & lngPercent & "% Complete..." 
                         
                        If .Cells(Q, P).Value <> wrkOrig.Cells(Q, P).Value Then 
                             'Highlight cell on updated sheet
                            With .Cells(Q, P).Interior 
                                .Pattern = xlSolid 
                                .PatternColorIndex = xlAutomatic 
                                .Color = 65535 
                                .TintAndShade = 0 
                                .PatternTintAndShade = 0 
                            End With 
                        End If 
                    End If 
                Next Q 
            Next P 
        End With 
         
ResumeChecking: 
         
    Next wrkUpdate 
     
    MsgBox "Update check complete! All items on the updated sheet that are different " & _ 
    "from those on the original sheet have been highlighted in yellow. Check the " & _ 
    "highlighted areas manually to verify the program results.", vbInformation, vbNullString 
     
    Application.StatusBar = False 
     
    Set wbkCtlPanel = Nothing 
    Set wbkOrigFile = Nothing 
    Set wbkUpdated = Nothing 
    Set wrkCtlPanel = Nothing 
    Set wrkOrig = Nothing 
    Set wrkUpdate = Nothing 
    Set rngLastOrig = Nothing 
    Set rngLastUpdate = Nothing 
    Set FSO = Nothing 
     
    Application.ScreenUpdating = True 
     
    Exit Sub 
     
ErrorSheetAdded: 
    MsgBox "ERROR! The updated file has a sheet named " & Chr(34) & wrkUpdate.Name & Chr(34) & _ 
    " that did not exist in the original file. This sheet will not be checked. Click OK to continue.", _ 
    vbExclamation, vbNullString 
     
    On Error GoTo 0 
     
    GoTo ResumeChecking 
End Sub 
 
 '***(Note: I did not write the LastCell function, but I don't remember who did - if it
 'was you, let me know who you are so I can give you credit!)***
 
Function LastCell(ws As Worksheet) As Range 
    Dim LastRow&, LastCol% 
     
     ' Error-handling is here in case there is not any
     ' data in the worksheet
     
    On Error Resume Next 
     
    With ws 
         
         ' Find the last real row
         
        LastRow& = .Cells.Find(What:="*", _ 
        SearchDirection:=xlPrevious, _ 
        SearchOrder:=xlByRows).Row 
         
         ' Find the last real column
         
        LastCol% = .Cells.Find(What:="*", _ 
        SearchDirection:=xlPrevious, _ 
        SearchOrder:=xlByColumns).Column 
         
    End With 
     
     ' Finally, initialize a Range object variable for
     ' the last populated row.
     
    Set LastCell = ws.Cells(LastRow&, LastCol%) 
     
End Function