Compare 2 workbooks and find the differences using Array

[Radhasweety]

I am trying 2 compare 2 workbooks loops but it is taking time. I want to compare 2 workbooks and find the differences Colud you pleas help on this.
Below is the code for loops

Public Function ExcelCmp(firstFile, secondFile, resultFile)
' Declaring varaibles
Dim objExcel1, objExcel2, objSpread1, objSpread2
Dim strCount, x1, x2, y1, y2, maxR, maxC, DiffCount, PDiffCount, limit, RowID
Dim cf1, cf2, fOffset, resOffSet, sMsg
Dim arrCol
    Dim keepColumn As Boolean
    Dim columnHeading As String
Dim returnVal  'As Boolean

returnVal = False
limit = 1
' Creates object of the two Excel files
Set objExcel1 = CreateObject("Excel.Application")
objExcel1.DisplayAlerts = False

resOffSet = 2
RowID = 0

'File exists or not?
If (FileExists(resultFile) = False) Then
    Set resBook = objExcel1.Workbooks.Add
  
    resBook.Sheets(1).Name = "Result"
    Set resWorkSheet = resBook.Worksheets("Result")
  
    'ID
    resWorkSheet.Cells(1, 1) = "ID"
    resWorkSheet.Cells(1, 1).Font.Bold = True
    resWorkSheet.Cells(1, 1).Interior.ColorIndex = 24
    'Status
    'resWorkSheet.Cells(1, 2) = "Status"
    'resWorkSheet.Cells(1, 2).Font.Bold = True
    'resWorkSheet.Cells(1, 2).Interior.ColorIndex = 24
    'Date
    'resWorkSheet.Cells(1, 3) = "Date Time"
    'resWorkSheet.Cells(1, 3).Font.Bold = True
    'resWorkSheet.Cells(1, 3).Interior.ColorIndex = 24
    'SyBase File location
    'resWorkSheet.Cells(1, 4) = "SyBase File location"
    'resWorkSheet.Cells(1, 4).Font.Bold = True
    'resWorkSheet.Cells(1, 4).Interior.ColorIndex = 24
    'SQL File location
    'resWorkSheet.Cells(1, 5) = "SQL File location"
    'resWorkSheet.Cells(1, 5).Font.Bold = True
    'resWorkSheet.Cells(1, 5).Interior.ColorIndex = 24
  
    'Worksheet
    resWorkSheet.Cells(1, 2) = "Sheet Name"
    resWorkSheet.Cells(1, 2).Font.Bold = True
    resWorkSheet.Cells(1, 2).Interior.ColorIndex = 24
    'Row No
    resWorkSheet.Cells(1, 3) = "Row No"
    resWorkSheet.Cells(1, 3).Font.Bold = True
    resWorkSheet.Cells(1, 3).Interior.ColorIndex = 24
    'Col No
    resWorkSheet.Cells(1, 4) = "Col No"
    resWorkSheet.Cells(1, 4).Font.Bold = True
    resWorkSheet.Cells(1, 4).Interior.ColorIndex = 24
    'Cell Value in SyBase
    resWorkSheet.Cells(1, 5) = "Data in Master"
    resWorkSheet.Cells(1, 5).Font.Bold = True
    resWorkSheet.Cells(1, 5).Interior.ColorIndex = 24
    'Cell Value in SQL
    resWorkSheet.Cells(1, 6) = "Data in Test Excel"
    resWorkSheet.Cells(1, 6).Font.Bold = True
    resWorkSheet.Cells(1, 6).Interior.ColorIndex = 24
  
Else
    Set resBook = objExcel1.Workbooks.Open(resultFile)
    Set resWorkSheet = resBook.Worksheets("sheet1")
   
  
    Do While resWorkSheet.Cells(resOffSet, 1) <> vbNullString
        RowID = resWorkSheet.Cells(resOffSet, 1).Value
        resOffSet = resOffSet + 1
     Loop
  
End If

If (FileExists(firstFile) = False Or FileExists(secondFile) = False) Then
    RowID = RowID + 1
     'ID
     resWorkSheet.Cells(resOffSet, 1) = RowID
     resWorkSheet.Cells(resOffSet, 1).Font.ColorIndex = 46
     'Status
     'resWorkSheet.Cells(resOffSet, 2) = "Missing File"
     'resWorkSheet.Cells(resOffSet, 2).Font.ColorIndex = 46
     'Date
     'resWorkSheet.Cells(resOffSet, 3) = Date & " " & Time()
     'resWorkSheet.Cells(resOffSet, 3).Font.ColorIndex = 46
     'SyBase file location
     'resWorkSheet.Cells(resOffSet, 4) = firstFile
     'resWorkSheet.Cells(resOffSet, 4).Font.ColorIndex = 46
     'resWorkSheet.Cells(resOffSet,2).Formula = "=Address("&r&","&c&",4)"
   
     'SQL file location
     'resWorkSheet.Cells(resOffSet, 5) = secondFile
     'resWorkSheet.Cells(resOffSet, 5).Font.ColorIndex = 46
     'resWorkSheet.Cells(resOffSet,2).Formula = "=Address("&r&","&c&",4)"
   
     'Worksheet
     resWorkSheet.Cells(resOffSet, 2) = ""
     resWorkSheet.Cells(resOffSet, 2).Font.ColorIndex = 46
   
     'Row No
     resWorkSheet.Cells(resOffSet, 3) = ""
     resWorkSheet.Cells(resOffSet, 3).Font.ColorIndex = 46
     'Col No
     resWorkSheet.Cells(resOffSet, 4) = ""
     resWorkSheet.Cells(resOffSet, 4).Font.ColorIndex = 46
     'Cell Value in SyBase
     resWorkSheet.Cells(resOffSet, 5) = "SyBase file Exists: " & FileExists(firstFile)
     resWorkSheet.Cells(resOffSet, 5).Font.ColorIndex = 46
     'Cell Value in SQL
     resWorkSheet.Cells(resOffSet, 6) = "SQL file Exists: " & FileExists(secondFile)
     resWorkSheet.Cells(resOffSet, 6).Font.ColorIndex = 46

   sMsg = "Files do not exist is specified location!"
Else
     Set objSpread1 = objExcel1.Workbooks.Open(firstFile)
     Set objSpread2 = objExcel1.Workbooks.Open(secondFile)
  
     'Get the number of worksheets used
     strCount = objSpread1.Worksheets.Count
     DiffCount = 0
     PDiffCount = 0
     'MsgBox strCount
   
     'Loop to identify the differences per worksheet
    
     For i = 1 To strCount
 
     'Get the row and column count of the first worksheet
      Set objWorksheet1 = objSpread1.Worksheets(i)
      With objWorksheet1.UsedRange
       x1 = .Rows.Count
       y1 = .Columns.Count
      End With
      'MsgBox x1 & " >> " & y1
      For toff = 1 To x1
       If (objWorksheet1.Cells(toff, 1) <> "") Then
        fOffset = toff
        Exit For
       End If
      Next
      'Get the row and column count of the the secound worksheet
      Set objWorksheet2 = objSpread2.Worksheets(i)
      With objWorksheet2.UsedRange
       x2 = .Rows.Count
       y2 = .Columns.Count
      End With
      maxR = x1
      maxC = y1
      If maxR < x2 Then
       maxR = x2
      End If
      If maxC < y2 Then
       maxC = y2
      End If
      'Loop to find the differences between the two files (cell by cell )
      cf1 = ""
      cf2 = ""
      For c = 1 To maxC
       For r = 1 To (maxR + fOffset)
        On Error Resume Next
        cf1 = LTrim(RTrim(objWorksheet1.Cells(r, c).Value))
        cf2 = LTrim(RTrim(objWorksheet2.Cells(r, c).Value))
        PDiffCount = DiffCount
        If IsNumeric(cf1) And IsNumeric(cf2) Then
         If Abs(cf1 - cf2) > limit Then
          DiffCount = DiffCount + 1
          cf2.Range(Cell.Address). _
            Interior.ColorIndex = 4
         End If
        Else
         If cf1 <> cf2 Then
            DiffCount = DiffCount + 1
            cf2.Range(Cell.Address). _
            Interior.ColorIndex = 4
            ' arrCol = Array("KEY-POL-NBR")
             '  Columns(arrCol(cf1)).EntireColumn.Delete
            End If
        End If
        
        If DiffCount >= (PDiffCount + 1) Then
       
        'resWorkSheet.Cells.Value = "KEY-POL-NBR"
        'Cell.EntireColumn.Delete
      
        'Change cell colour in reports
         'objWorksheet1.Cells(r, c).Interior.ColorIndex = 3
         'objWorksheet2.Cells(r, c).Interior.ColorIndex = 3
       
         RowID = RowID + 1
  
      
         'ID
         resWorkSheet.Cells(resOffSet, 1) = RowID
         resWorkSheet.Cells(resOffSet, 1).Font.ColorIndex = 3
         'Status
         'resWorkSheet.Cells(resOffSet, 2) = "Issue"
         'resWorkSheet.Cells(resOffSet, 2).Font.ColorIndex = 3
         'Date
         'resWorkSheet.Cells(resOffSet, 3) = Date & " " & Time()
         'resWorkSheet.Cells(resOffSet, 3).Font.ColorIndex = 3
         'SyBase file location
         'resWorkSheet.Cells(resOffSet, 4) = firstFile
         'resWorkSheet.Cells(resOffSet, 4).Font.ColorIndex = 3
         'resWorkSheet.Cells(resOffSet,2).Formula = "=Address("&r&","&c&",4)"
       
         'Fielname
         'resWorkSheet.Cells(resOffSet, 5) = secondFile
         'resWorkSheet.Cells(resOffSet, 5).Font.ColorIndex = 3
         'resWorkSheet.Cells(resOffSet,2).Formula = "=Address("&r&","&c&",4)"
       
         'Worksheet
         resWorkSheet.Cells(resOffSet, 2) = objWorksheet1.Name
         resWorkSheet.Cells(resOffSet, 2).Font.ColorIndex = 3
       
         'Row No
         resWorkSheet.Cells(resOffSet, 3) = r
         resWorkSheet.Cells(resOffSet, 3).Font.ColorIndex = 3
         'Col No
         resWorkSheet.Cells(resOffSet, 4) = objWorksheet1.Cells(fOffset, c).Value
         resWorkSheet.Cells(resOffSet, 4).Font.ColorIndex = 3
         'Cell Value in SyBase
         resWorkSheet.Cells(resOffSet, 5) = objWorksheet1.Cells(r, c).Value
         resWorkSheet.Cells(resOffSet, 5).Font.ColorIndex = 3
         'Cell Value in SQL
         resWorkSheet.Cells(resOffSet, 6) = objWorksheet2.Cells(r, c).Value
         resWorkSheet.Cells(resOffSet, 6).Font.ColorIndex = 3
       
  
         resOffSet = resOffSet + 1
      
        
        End If
     
        cf1 = ""
        cf2 = ""
       Next
      Next
     Next

    If DiffCount = 0 Then
        RowID = RowID + 1
        'ID
        resWorkSheet.Cells(resOffSet, 1) = RowID
        resWorkSheet.Cells(resOffSet, 1).Font.ColorIndex = 50
        'Status
        'resWorkSheet.Cells(resOffSet, 2) = "Match"
        'resWorkSheet.Cells(resOffSet, 2).Font.ColorIndex = 50
        'Date
        'resWorkSheet.Cells(resOffSet, 3) = Date & " " & Time()
        'resWorkSheet.Cells(resOffSet, 3).Font.ColorIndex = 50
        'SyBase file location
        'resWorkSheet.Cells(resOffSet, 4) = firstFile
        'resWorkSheet.Cells(resOffSet, 4).Font.ColorIndex = 50
        'resWorkSheet.Cells(resOffSet,2).Formula = "=Address("&r&","&c&",4)"
      
        'SQL file location
        'resWorkSheet.Cells(resOffSet, 5) = secondFile
        'resWorkSheet.Cells(resOffSet, 5).Font.ColorIndex = 50
        'resWorkSheet.Cells(resOffSet,2).Formula = "=Address("&r&","&c&",4)"
      
        'Worksheet
        resWorkSheet.Cells(resOffSet, 2) = ""
        resWorkSheet.Cells(resOffSet, 2).Font.ColorIndex = 50
      
        'Row No
        resWorkSheet.Cells(resOffSet, 3) = ""
        resWorkSheet.Cells(resOffSet, 3).Font.ColorIndex = 50
        'Col No
        resWorkSheet.Cells(resOffSet, 4) = ""
        resWorkSheet.Cells(resOffSet, 4).Font.ColorIndex = 50
        'Cell Value in SyBase
        resWorkSheet.Cells(resOffSet, 5) = "NA"
        resWorkSheet.Cells(resOffSet, 5).Font.ColorIndex = 50
        'Cell Value in SQL
        resWorkSheet.Cells(resOffSet, 6) = "NA"
        resWorkSheet.Cells(resOffSet, 6).Font.ColorIndex = 50
   
   
     sMsg = "No Errors Found !!!"
     returnVal = True
    Else
   
     sMsg = "Error in Validation : " & DiffCount & " Items Mismatches!!!" & vbLf & "Results File available at : " & resultFile
    End If
End If

  If (FileExists(resultFile) = False) Then
    resBook.SaveAs resultFile
  Else
    resBook.Save
  End If

'Close spreadsheets
resBook.Close savechanges:=False
If (FileExists(firstFile) = True And FileExists(secondFile) = True) Then
    objSpread1.Close savechanges:=False
    objSpread2.Close savechanges:=False
End If

'objExcel1.DisplayAlerts = True
objExcel1.Quit

Set objSpread1 = Nothing
Set objSpread2 = Nothing
Set objExcel1 = Nothing
Set resBook = Nothing
Set resWorkSheet = Nothing
ExcelCmp = sMsg

End Function


' returns TRUE if the file exists
Function FileExists(FullFileName) As Boolean


  FileExists = Len(Dir(FullFileName)) > 0
   Application.ScreenUpdating = True


Option Explicit
Dim sfile As String
Dim sfile1 As String


Sub CommandButton1_Click()
Dim directory As String
  Dim fd As Office.FileDialog
  Dim fname As String
  Dim fpath As String
 
   directory = Environ$("USERPROFILE") & "\Documents"
  If Dir(directory, vbDirectory) = "" Then
    directory = "%USERPROFILE%" & "\"
    Else: directory = directory
    End If
 
  'Select file to work with
  Set fd = Application.FileDialog(msoFileDialogFilePicker)

  With fd
    .AllowMultiSelect = False
    .Title = "Select File to process."
    .InitialFileName = directory
    .Filters.Clear
    .Filters.Add "SCUBI files", "*.xls, *xlsx, .xlsm"
    If .Show = True Then
      fname = Dir(.SelectedItems(1))
      fpath = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), "\"))
       Else: GoTo Continue
    End If
  End With
 
  'set path and file name for later use
  sfile = fpath & fname
  Debug.Print sfile
Continue:

End Sub
Sub CommandButton2_Click()
Dim directory1 As String
  Dim fd1 As Office.FileDialog
  Dim fname1 As String
  Dim fpath1 As String
  'Dim sfile1 As String
   directory1 = Environ$("USERPROFILE") & "\Documents"
  If Dir(directory1, vbDirectory) = "" Then
    directory1 = "%USERPROFILE%" & "\"
    Else: directory1 = directory1
    End If
 
  'Select file to work with
  Set fd1 = Application.FileDialog(msoFileDialogFilePicker)

  With fd1
    .AllowMultiSelect = False
    .Title = "Select File to process."
    .InitialFileName = directory1
    .Filters.Clear
    .Filters.Add "SCUBI files", "*.xls, *xlsx, .xlsm"
    If .Show = True Then
      fname1 = Dir(.SelectedItems(1))
      fpath1 = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), "\"))
       Else: GoTo Continue
    End If
  End With
 
  'set path and file name for later use
  sfile1 = fpath1 & fname1
  Debug.Print sfile1
Continue:
End Sub
Public Sub CommandButton3_Click()
Dim resfile As String
Dim res As String


   'xlfile1 = sfile
   'xlfile2 = sfile1
   resfile = "U:\FinalOutput.xlsx"
   res = ExcelCmp(sfile, sfile1, resfile)
End Sub





End Function

 

[NdNoviceHlp]

Hi Radhasweety and Welcome to the Board! A few things, why are U creating another XL application rather than just opening wbs? How do you want the differences displayed and in what wb? Here's some code that I had previous. You will need to adjust the filepaths. This code indicates differences in the comparison wb (see code notes). To return the comparison wb to normal, comment out the blue and yellow lines of code and remove the comment from both "white" lines of code. HTH. Dave

Public Sub Compare2Wbs()
Dim RowCnt As Double, ColCnt As Double, OrigWb As Object, CompareWb As Object
Dim LastRow As Double, LastCol As Double, Sht As Worksheet, StartTemp As Variant
'*Ensures sheet data in CompareWb is the same as OrigWb
' CompareWb cell(s) are blue in CompareWb IF data exists in OrigWb AND
'         the data is NOT the same in the CompareWb
' CompareWb cell(s) are yellow IF data exists in CompareWb
'                        that did NOT originally exist in OrigWb

On Error GoTo FixEr
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'change file address to suit
Set OrigWb = Workbooks.Open("D:\test.xlsm")
Set CompareWb = Workbooks.Open("D:\Test2.xlsm")
'turn CompareWb cell(s) blue IF data exists in OrigWb AND
'         the data is NOT the same in the CompareWb
For Each Sht In OrigWb.Worksheets
'use StartTemp to set usedrange. Restore A1 @ end with StartTemp
'   (ie. need A1 cell filled to set usedrange)
StartTemp = OrigWb.Sheets(Sht.Name).Cells(1, 1) 'temp store A1
If OrigWb.Sheets(Sht.Name).Cells(1, 1) = vbNullString Then
OrigWb.Sheets(Sht.Name).Cells(1, 1) = 1 'fill cell to set usedrange
End If
'set sht range size
LastRow = OrigWb.Sheets(Sht.Name).UsedRange.Rows.Count
LastCol = OrigWb.Sheets(Sht.Name).UsedRange.Columns.Count

For RowCnt = 1 To LastRow 'loop sht rows
For ColCnt = 1 To LastCol 'loop sheet cols
'don't search error cells
If Not IsError(OrigWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt)) Then
'don't search blank cells
If OrigWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt) <> vbNullString Then
'color differences in blue if wb cell values are different
If OrigWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt) <> _
       CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt) Then
CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Interior.Color = vbCyan 'blue
'CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Interior.Color = vbWhite 'white
CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Borders.LineStyle = xlContinuous
CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Borders.Color = RGB(170, 170, 170) 'grey
End If
End If
End If
Next ColCnt
Next RowCnt
OrigWb.Sheets(Sht.Name).Cells(1, 1) = StartTemp ' restore original value
Next Sht

'Turn CompareWb cell(s) yellow IF data exists in CompareWb
'     that did NOT originally exist in OrigWb
For Each Sht In CompareWb.Worksheets
'use StartTemp to set usedrange. Restore A1 @ end with StartTemp
'   (ie. need A1 cell filled to set usedrange)
StartTemp = CompareWb.Sheets(Sht.Name).Cells(1, 1) 'temp store A1
If CompareWb.Sheets(Sht.Name).Cells(1, 1) = vbNullString Then
CompareWb.Sheets(Sht.Name).Cells(1, 1) = 1 'fill cell to set usedrange
End If
'set sht range size
LastRow = CompareWb.Sheets(Sht.Name).UsedRange.Rows.Count
LastCol = CompareWb.Sheets(Sht.Name).UsedRange.Columns.Count

For RowCnt = 1 To LastRow 'loop rows
For ColCnt = 1 To LastCol 'loop cols
'don't search error cells
If Not IsError(CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt)) Then
'don't search if already blue
If CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Interior.Color <> vbCyan Then
'don't search if blank
If CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt) <> vbNullString Then
'color CompareWb cell yellow IF
'              value exists in CompareWb that did NOT exist in origwb
If OrigWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt) <> _
       CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt) Then
CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Interior.Color = vbYellow 'yellow
'CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Interior.Color = vbWhite 'white
CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Borders.LineStyle = xlContinuous
CompareWb.Sheets(Sht.Name).Cells(RowCnt, ColCnt).Borders.Color = RGB(170, 170, 170) 'grey
End If
End If
End If
End If
Next ColCnt
Next RowCnt
CompareWb.Sheets(Sht.Name).Cells(1, 1) = StartTemp
Next Sht

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = False
OrigWb.Save
OrigWb.Close
Set OrigWb = Nothing
CompareWb.Save
CompareWb.Close
Set CompareWb = Nothing
Application.DisplayAlerts = True
Exit Sub

FixEr:
On Error GoTo 0
MsgBox "File error likely"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = False
OrigWb.Close
Set OrigWb = Nothing
CompareWb.Close
Set CompareWb = Nothing
Application.DisplayAlerts = True
End Sub