VB Script to Compare Two Excel Files with Multiple Tabs

Introduction

Any Excel Comparator does the comparison for single Tab at a time but this Entire script compares the number of tabs present in both the excel sheets provided.

Background

The VBScript needs to be provided with Source Files (to be compared) and a path for the Result File to be stored. The Script then can be run (w/o opening the Excels). And the script itself navigates through the tabs one after another and compares the data present.

The code

Code:

'Provide the File details here
xlfile1 = "C:\File1.xls"
xlfile2 = "C:\File2.xls"
resfile = "C:\ResFile.xls"
Res = ExcelCmp(xlfile1,xlfile2,resfile)
' Function to compare the two excel files
Public Function ExcelCmp(firstFile,secondFile,resultFile)
' Declaring varaibles 
 Dim  objExcel1,objExcel2,objSpread1,objSpread2
 Dim  strCount,x1,x2,y1,y2,maxR,maxC,DiffCount,PDiffCount,limit
 Dim  cf1,cf2,fOffset,resOffSet,sMsg
 Dim  returnVal 'As Boolean
 returnVal = False
 limit = 1
 ' Creates object of the two Excel files
 Set objExcel1 = CreateObject("Excel.Application")
 objExcel1.displayalerts = false
 Set objSpread1 = objExcel1.Workbooks.Open(firstFile)
 Set objSpread2 = objExcel1.Workbooks.Open(secondFile)
 Set resBook = objExcel1.Workbooks.Add
 resBook.Sheets(1).Name = "Result"
 Set resWorkSheet = resBook.WorkSheets("Result")
 'Preparing the Headers and details in the Result File
 resWorkSheet.Cells(1,1) = "This is a result file which highlights the differences between the Files ..."
 resWorkSheet.Cells(2,1) = "File 1 : " + firstFile
 resWorkSheet.Cells(3,1) = "File 2 : " + secondFile
 resWorkSheet.Cells(4,1) = "'==========================================================================================="
 resWorkSheet.Range(resWorkSheet.Cells(1,1), resWorkSheet.Cells(1,12)).Merge
 resWorkSheet.Range(resWorkSheet.Cells(2,1), resWorkSheet.Cells(2,12)).Merge
 resWorkSheet.Range(resWorkSheet.Cells(3,1), resWorkSheet.Cells(3,12)).Merge
 resWorkSheet.Range(resWorkSheet.Cells(4,1), resWorkSheet.Cells(4,12)).Merge
 
 resWorkSheet.Cells(6,1) = "Item Name"
 resWorkSheet.Cells(6,1).Font.Bold = TRUE
 resWorkSheet.Cells(6,2) = "Location"
 resWorkSheet.Cells(6,2).Font.Bold = TRUE
 resWorkSheet.Cells(6,3) = "Data in File 1"
 resWorkSheet.Cells(6,3).Font.Bold = TRUE
 resWorkSheet.Cells(6,4) = "Data in File 2"
 resWorkSheet.Cells(6,4).Font.Bold = TRUE
 resOffSet = 7
 ' 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
     End If
    Else
     If cf1 <> cf2 Then
     DiffCount = DiffCount+1
     End If
    End If
    
    If DiffCount >= (PDiffCount+1) Then
     objWorksheet1.Cells(r,c).Interior.ColorIndex = 3
     objWorksheet2.Cells(r,c).Interior.ColorIndex = 3
     resWorkSheet.Cells(resOffSet,1) = objWorksheet1.Cells(fOffset,c).Value
     resWorkSheet.Cells(resOffSet,2).Formula = "=Address("&r&","&c&",4)"
     resWorkSheet.Cells(resOffSet,3) = objWorksheet1.Cells(r,c).Value
     resWorkSheet.Cells(resOffSet,4) = objWorksheet2.Cells(r,c).Value
     resOffSet = resOffSet + 1
    End If
    
    cf1 = ""
    cf2 = ""
   Next
  Next
 Next
 If DiffCount=0 Then
  sMsg = "No Errors Found !!!"
  returnVal = True
 Else
  resBook.SaveAs resultFile
  sMsg =  "Error in Validation : " & DiffCount & " Items Mismatches!!!" & vbLF & "Results File available at : " & resultFile
 End If
 
 resBook.Close
 objSpread1.Close
 objSpread2.Close
 
 objExcel1.displayalerts = True
 objExcel1.Quit
 Set objSpread1 = Nothing
 Set objSpread2 = Nothing
 Set objExcel1 = Nothing
 Set resBook = Nothing
Excelcmp = sMsg
End Function

 

Why do you rate your own articles as 5.00 ??!?

Let the members rate it ! An author obviously likes his/her own article.

 

Nice one.
Few days back someone was asking me if I can write an excel macro to compare to sheets/workbooks

 

its easy, you freeze the rows and see what happen.

 

Q : Why do you rate your own articles ??!?

A : An author obviously likes his/her own article.

Any more clarification ?

 

I have created a software using this, planning to sell it

 

i like you script because the ordinary Excel Comparator does the comparison only for single Tabs at one time... but this script compares the number of tabs present in both the excel sheets provided. Works likea charm

 

i am not getting any errors but no results file. please help.

 

did not work in larger files? any help will be appreciated!!