Compare two Excel sheets by Cell Content

Question

This code is a result of a lot of help from this community. What does it do? It compares two excel sheets cell by cell and copies the differences into another excel file.

I’m trying to modify the Code so it does the following:

It goes to "Name" and then searches for that name is the other file. If it doesn’t find the file it just copies that entire row including all the columns to the report file (file that is created) In case it does find the name, then it compares all the columns of that row and if something different it shows the difference in report with color red.

The pictures below show what I'm trying to achieve with this code

Sheet1 enter image description here

Sheet2

enter image description here

Report enter image description here

Sub Compare2WorkSheets(ws1 As Worksheet, ws2 As Worksheet)
 Dim ws1row As Long, ws2row As Long, ws1col As Integer, ws2col As Integer
 Dim maxrow As Long, maxcol As Integer, colval1 As String, colval2 As String
 Dim Report As Workbook, difference As Long
 Dim row As Long, col As Integer
 Dim Arr1 As Variant, Arr2 As Variant, Arr3 As Variant, Rng As Range
 Dim tm As Double
 tm = Timer
 'Application.ScreenUpdating = False
 'Application.Calculation = xlCalculationManual
 'Application.EnableEvents = False
 With ws1.UsedRange
 ws1row = .Rows.Count
 ws1col = .Columns.Count
 End With
 With ws2.UsedRange
 ws2row = .Rows.Count
 ws2col = .Columns.Count
 End With
 maxrow = ws1row
 maxcol = ws1col
 If maxrow < ws2row Then maxrow = ws2row
 If maxcol < ws2col Then maxcol = ws2col
 Debug.Print maxrow, maxcol
 Arr1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(maxrow, maxcol)).Formula
 Arr2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(maxrow, maxcol)).Formula
 ReDim Arr3(1 To UBound(Arr1, 1), 1 To UBound(Arr1, 2))
 difference = 0
 For col = 1 To maxcol
 For row = 1 To maxrow
 If Arr1(row, col) <> Arr2(row, col) Then
 difference = difference + 1
 Arr3(row, col) = Arr1(row, col) & "<> " & Arr2(row, col)
 Else
 Arr3(row, col) = ""
 End If
 Next row
 Next col
 Debug.Print " Calc secs " & Timer - tm
 If difference > 0 Then
 Set Report = Workbooks.Add
 With Report.ActiveSheet
 .Range("A1").Resize(UBound(Arr3, 1), UBound(Arr3, 2)).Value = Arr3
 .Columns("A:B").ColumnWidth = 25
 Set Rng = .Range(Report.ActiveSheet.Cells(1, 1), Report.ActiveSheet.Cells(UBound(Arr3, 1), UBound(Arr3, 2)))
 End With
 With Rng
 .FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, Formula1:="=""""" '""""""""
 .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
 With .FormatConditions(1)
 .Interior.Color = 255
 .Font.Bold = True
 .Font.ColorIndex = 2
 End With
 End With
 Debug.Print "Report Generated secs " & Timer - tm
 End If
 'Set Report = Nothing
 'Application.ScreenUpdating = True
 'Application.Calculation = xlCalculationAutomatic
 'Application.EnableEvents = True
 MsgBox difference & " cells contain different data! ", vbInformation, "Comparing Two Worksheets"
End Sub

How do I run this code?

I add the code into a module and then create a button and do the following.

The first picture shows how I call the sub to compare the two sheets

enter image description here

The second pictures shows how I open up another file and compare two Excel files.

enter image description here

• Ahmed AU: It is possible if the names are unique only. if the rows in question are as high as in your last question then it seems that is unlikely. Please comment back.
• Miriam List: @Ahmed AU I want to compare by name( column H). Find the sheet which has more rows and start from the first row (Lenovo700), then loop through column H of sheet2 and find which row has Lenovo700 and then compare the first row Sheet1 with the row where we located the same NAME in Sheet2
• Miriam List: @ Ahmed AU as far I understand we should only modify the loops but can't seem to get it right
• PeterT: Your logic seems clear that you want to find a Name and compare rows, but @AhmedAU question is still important: what happens if you the same name appearing many times in both sheets? For example, "Lenovo700" could appear 12 times on Sheet1 and 23 times on Sheet2. How can you decide if any row is unique if a name is repeated like that? One possibility is that a combination of Name and Country may create a unique entry. Your other post indicated that you could have over 10,000 rows, so it seems unlikely that there will be 10,000 unique names (though it's possible, if that is your situation).
• Ahmed AU: @PeterT Thanks for explaining my point better than me.

Answer 1

This answer assumes that all Names in the data are unique. There is no provision in this example to handle duplicate Names except to issue a note in the debug output.

This answer will involve Dictionaries. Please review this website for complete information on how and why they are an efficient way to store unique data. The short answer is that you can create a large dictionary by looking at a unique "key", which is a string that uniquely represents some data that you want to track. In your case, you've asserted that all of the Names are unique. Dictionaries exist for speedy access to any single entry -- no looping through 200k entries to find the one you want. Use your unique key string and you have near-instant access to the data associated with that key.

For your situation, my example builds two Dictionaries, one for each set of data. The keys are the Names. The values associated with each key (Name) is the row number on which each Name is used. The row numbers will play a major role later on.

As with the other Code Review for your previous version of code, I'll reiterate:

1. Identify your function parameters ByRef or ByVal
2. Declare your variables as close to their first use as possible.

As an example:

Dim arr1 As Variant
Dim arr2 As Variant
arr1 = BuildDataArrays(ws1, startRow:=2)
arr2 = BuildDataArrays(ws2, startRow:=2)

You'll see that there is a call to a BuildDataArrays function. That brings me to

3. Functional Isolation. When your routine starts getting very long, that is the perfect time to begin breaking parts of the logic out into separate functions/subs. This is especially useful if you have repetitive logic where only the variable is different. This is the case for BuildDataArrays.

Give this function a worksheet and optionally the starting row or column and it determines the range of available data, returning a memory-based array. Breaking out code into separate routines is very helpful because it makes your main logic easier to follow.

Private Function BuildDataArrays(ByRef ws As Worksheet, _
 Optional ByVal startRow As Long = 1, _
 Optional ByVal startCol As Long = 1) As Variant
 '--- assumes all rows and columns are valid data
 Dim lastRow As Long
 Dim lastCol As Long
 Dim dataArea As Range
 Dim data As Variant
 With ws
 lastRow = .Cells(.Rows.Count, startRow).End(xlUp).row
 lastCol = .Cells(startCol, .Columns.Count).End(xlToLeft).Column
 Set dataArea = .Cells(startRow, startCol).Resize(lastRow - startRow + 1, _
 lastCol - startCol + 1)
 data = dataArea
 End With
 BuildDataArrays = data
End Function

4. Use Dictionaries to collect your data. As with the previous point, this is a perfect opportunity to isolate the logic in a separate function.

The BuildDataDictionary function will accept your memory-based array and use the selected column of data as a unique key (currently defaulted to column "I").

Private Function BuildDataDictionary(ByRef data As Variant, _
 Optional ByVal keyColumn As Long = 8) As Dictionary
 Dim row As Long
 Dim name As String
 Dim names As Dictionary
 Set names = New Dictionary
 For row = LBound(data, 1) To UBound(data, 1)
 name = Trim$(data(row, keyColumn))
 If Len(name) > 0 Then
 If Not names.Exists(name) Then
 '--- add the new name to the dictionary and save the row number
 names.Add name, row
 Else
 '--- if you get here, it means that the Name is NOT unique
 ' and you'll have to change your logic, or change the name
 Debug.Print "ERROR: Duplicate name detected on " & _
 " on row " & row & ": '" & name & "'"
 End If
 End If
 Next row
 Set BuildDataDictionary = names
End Function

Next we'll build the resulting report data. According to your description, the report will consist of all data rows (each with a unique Name), with any differences noted in the data itself. In your original post, you are assuming that the larger of the two row counts for the sheets will be your output array. This isn't true.

Consider that, by definition, all of the data from Sheet1 is unique (because each row's Name is unique). That means if you have 10 rows of data on Sheet1, your output data will have at least ten rows. It's possible that your data on Sheet2 also has ten rows of data, and only one of those rows repeats a Name on Sheet1. So your resulting report of data will have 19 rows.

Dim totalRows As Long
totalRows = ws1Names.Count
'--- now add on the number of unique rows from the other sheet
Dim name As Variant
For Each name In ws2Names
 If Not ws1Names.Exists(name) Then
 '--- name is unique
 totalRows = totalRows + 1
 Else
 '--- name is not unique
 End If
Next name
Debug.Print "There are " & totalRows & " unique Names between the sheets"
'--- now build a correctly sized output array
' ASSUMES both arrays have the same number of columns!!
Dim reportData As Variant
ReDim reportData(1 To totalRows, 1 To UBound(arr1, 2))

Now that we're about to generate the report data, we have to consider how to make note of any errors encountered. For this I'm using a Collection, which is a simple way to generate a running list of items. In this case, for each difference I'm adding a string that notes the row and column of each difference in the data arrays. I can use this later on to highlight the difference cells.

'--- and create an object to list which cells are different
Dim diffCells As Collection
Set diffCells = New Collection

After that, we simply move the data over to the report array, making note of any differences.

'--- we know that all Names are unique in sheet1, so move the all that
' data from sheet1 into the report array
Dim row As Long
Dim col As Long
Dim ws1row As Long
Dim ws2row As Long
row = 1
For Each name In ws1Names
 If ws2Names.Exists(name) Then
 '--- this row will have a difference because the Names match!
 ' so get the rows for each sheet that match the name
 ws1row = ws1Names(name)
 ws2row = ws2Names(name)
 For col = 1 To UBound(reportData, 2)
 If arr1(ws1row, col) = arr2(ws2row, col) Then
 reportData(row, col) = arr1(ws1row, col)
 Else
 '--- note the different values in the cell and add the
 ' row and column to the difference list
 reportData(row, col) = arr1(ws1row, col) & " <> " & _
 arr2(ws2row, col)
 diffCells.Add CLng(row) & "," & CLng(col)
 End If
 Next col
 Else
 '--- this is a unique row, so a straight copy of all columns
 For col = 1 To UBound(reportData, 2)
 reportData(row, col) = arr1(row, col)
 Next col
 End If
 row = row + 1
Next name
'--- the remaining data are the unique rows that exist in sheet2
' the "row" variable count is continued in this loop
For Each name In ws2Names
 If Not ws1Names.Exists(name) Then
 '--- this is a unique row, so a straight copy of all columns
 ws2row = ws2Names(name)
 For col = 1 To UBound(reportData, 2)
 reportData(row, col) = arr2(ws2row, col)
 Next col
 row = row + 1
 End If
Next name

The final step is to output the report data. In my example, I am not creating a new workbook, but only creating a new worksheet. You can un-comment some code lines there to change it back for your purposes.

If diffCells.Count > 0 Then
 Dim report As Workbook
 Dim reportWS As Worksheet
 'Set report = Workbooks.Add 'un-comment to report to a new workbook
 'Set reportWS = report.ActiveSheet 'un-comment to report to a new workbook
 Set reportWS = ThisWorkbook.Sheets.Add 'comment to report to a new workbook
 '--- copy the resulting report to the worksheet
 Dim reportArea As Range
 Set reportArea = reportWS.Range("A1").Resize(UBound(reportData, 1), UBound(reportData, 2))
 With reportArea
 .Value = reportData
 .Columns("A:B").ColumnWidth = 25
 '--- now highlight the cells that are different
 Dim rowcol As Variant
 Dim parts() As String
 For Each rowcol In diffCells
 parts = Split(rowcol, ",")
 With .Cells(CLng(parts(0)), CLng(parts(1)))
 .Font.Bold = True
 .Font.ColorIndex = 3
 End With
 Next rowcol
 End With
 Debug.Print "Report Generated secs " & Timer - tm
End If

Here is the whole code module in one block:

Option Explicit
Sub test1()
 Compare2WorkSheets Sheet1, Sheet2
End Sub
Sub Compare2WorkSheets(ByRef ws1 As Worksheet, ByRef ws2 As Worksheet)
 Dim tm As Double
 tm = Timer
 'Application.ScreenUpdating = False
 'Application.Calculation = xlCalculationManual
 'Application.EnableEvents = False
 '--- establish the data in the arrays, skip the header row
 Dim arr1 As Variant
 Dim arr2 As Variant
 arr1 = BuildDataArrays(ws1, startRow:=2)
 arr2 = BuildDataArrays(ws2, startRow:=2)
 '--- buidl a dictionary of Names for each worksheet
 Dim ws1Names As Dictionary
 Dim ws2Names As Dictionary
 Set ws1Names = BuildDataDictionary(arr1)
 Set ws2Names = BuildDataDictionary(arr2)
 '--- we don't know how many rows the report will be, so compare
 ' names between the two sheets to find out. it's basically
 ' the sum of the number of unique names between the sheets
 Dim totalRows As Long
 totalRows = ws1Names.Count
 '--- now add on the number of unique rows from the other sheet
 Dim name As Variant
 For Each name In ws2Names
 If Not ws1Names.Exists(name) Then
 '--- name is unique
 totalRows = totalRows + 1
 Else
 '--- name is not unique
 End If
 Next name
 Debug.Print "There are " & totalRows & " unique Names between the sheets"
 '--- now build a correctly sized output array
 ' ASSUMES both arrays have the same number of columns!!
 Dim reportData As Variant
 ReDim reportData(1 To totalRows, 1 To UBound(arr1, 2))
 '--- and create an object to list which cells are different
 Dim diffCells As Collection
 Set diffCells = New Collection
 '--- we know that all Names are unique in sheet1, so move the all that
 ' data from sheet1 into the report array
 Dim row As Long
 Dim col As Long
 Dim ws1row As Long
 Dim ws2row As Long
 row = 1
 For Each name In ws1Names
 If ws2Names.Exists(name) Then
 '--- this row will have a difference because the Names match!
 ' so get the rows for each sheet that match the name
 ws1row = ws1Names(name)
 ws2row = ws2Names(name)
 For col = 1 To UBound(reportData, 2)
 If arr1(ws1row, col) = arr2(ws2row, col) Then
 reportData(row, col) = arr1(ws1row, col)
 Else
 '--- note the different values in the cell and add the
 ' row and column to the difference list
 reportData(row, col) = arr1(ws1row, col) & " <> " & _
 arr2(ws2row, col)
 diffCells.Add CLng(row) & "," & CLng(col)
 End If
 Next col
 Else
 '--- this is a unique row, so a straight copy of all columns
 For col = 1 To UBound(reportData, 2)
 reportData(row, col) = arr1(row, col)
 Next col
 End If
 row = row + 1
 Next name
 '--- the remaining data are the unique rows that exist in sheet2
 ' the "row" variable count is continued in this loop
 For Each name In ws2Names
 If Not ws1Names.Exists(name) Then
 '--- this is a unique row, so a straight copy of all columns
 ws2row = ws2Names(name)
 For col = 1 To UBound(reportData, 2)
 reportData(row, col) = arr2(ws2row, col)
 Next col
 row = row + 1
 End If
 Next name
 Debug.Print " Calc secs " & Timer - tm
 If diffCells.Count > 0 Then
 Dim report As Workbook
 Dim reportWS As Worksheet
 'Set report = Workbooks.Add 'un-comment to report to a new workbook
 'Set reportWS = report.ActiveSheet 'un-comment to report to a new workbook
 Set reportWS = ThisWorkbook.Sheets.Add 'comment to report to a new workbook
 '--- copy the resulting report to the worksheet
 Dim reportArea As Range
 Set reportArea = reportWS.Range("A1").Resize(UBound(reportData, 1), UBound(reportData, 2))
 With reportArea
 .Value = reportData
 .Columns("A:B").ColumnWidth = 25
 '--- now highlight the cells that are different
 Dim rowcol As Variant
 Dim parts() As String
 For Each rowcol In diffCells
 parts = Split(rowcol, ",")
 With .Cells(CLng(parts(0)), CLng(parts(1)))
 .Font.Bold = True
 .Font.ColorIndex = 3
 End With
 Next rowcol
 End With
 Debug.Print "Report Generated secs " & Timer - tm
 End If
 'Application.ScreenUpdating = True
 'Application.Calculation = xlCalculationAutomatic
 'Application.EnableEvents = True
 If diffCells.Count > 0 Then
 Debug.Print diffCells.Count & " cells contain different data!"
 Else
 Debug.Print "No differences found between the sheets."
 End If
End Sub
Private Function BuildDataArrays(ByRef ws As Worksheet, _
 Optional ByVal startRow As Long = 1, _
 Optional ByVal startCol As Long = 1) As Variant
 '--- assumes all rows and columns are valid data
 Dim lastRow As Long
 Dim lastCol As Long
 Dim dataArea As Range
 Dim data As Variant
 With ws
 lastRow = .Cells(.Rows.Count, startRow).End(xlUp).row
 lastCol = .Cells(startCol, .Columns.Count).End(xlToLeft).Column
 Set dataArea = .Cells(startRow, startCol).Resize(lastRow - startRow + 1, _
 lastCol - startCol + 1)
 data = dataArea
 End With
 BuildDataArrays = data
End Function
Private Function BuildDataDictionary(ByRef data As Variant, _
 Optional ByVal keyColumn As Long = 8) As Dictionary
 Dim row As Long
 Dim name As String
 Dim names As Dictionary
 Set names = New Dictionary
 For row = LBound(data, 1) To UBound(data, 1)
 name = Trim$(data(row, keyColumn))
 If Len(name) > 0 Then
 If Not names.Exists(name) Then
 '--- add the new name to the dictionary and save the row number
 names.Add name, row
 Else
 '--- if you get here, it means that the Name is NOT unique
 ' and you'll have to change your logic, or change the name
 Debug.Print "ERROR: Duplicate name detected on " & _
 " on row " & row & ": '" & name & "'"
 End If
 End If
 Next row
 Set BuildDataDictionary = names
End Function

EDIT: added an example on how to call the routine from a button click

It seems that you're adding an ActiveX command button to your worksheet. In this case, the CommandButton1_Click() method will be executed in the Sheet1 module. Take the code above with the Compare2WorkSheets routine and paste it into a regular code module. Then, in your sheet1 module, fix up your button-click code like this:

Option Explicit
Private Sub CommandButton1_Click()
 Dim myWorkbook1 As Workbook
 Dim myWorkbook2 As Workbook
 '--- if Sheet1 is contained in the workbook where the code is running, use this
 Set myWorkbook1 = ThisWorkbook
 '--- if Sheet1 is in a different -- but already open -- workbook, use this
 Set myWorkbook1 = Workbooks("the-already-open-workbook-filename.xlsx")
 '--- if Sheet1 is in a different -- but unopened -- workbook, use this
 Set myWorkbook1 = Workbooks.Open("the-workbook-filename-to-open.xlsx")
 '--- you can make the same decisions for setting myWorkbook2
 Set myWorkbook2 = Workbooks.Open("C:\Temp\testreport1.xlsx")
 Compare2WorkSheets myWorkbook1.Worksheets("Sheet1"), myWorkbook2.Worksheets("Sheet1")
 myWorkbook1.Close
 myWorkbook2.Close
End Sub

• Miriam List: thank you for this incredible answer . I read the description and learned a lot. Until now I wasn't able to make it run. I usually just use a button and call the sub. I added the part on how I run the code in question above. Until now I don't know how to do that with your code
• PeterT: @MiriamList - there are a couple issues: 1) you're trying to execute your VBA code from a non-macro workbook named File1.xlsx', if this is a temporary workbook for testing, that's okay but you can't save your macro code in it, and 2) in your parameter Workbooks("testcompare1.xlsm").Worksheets("Sheet1"), this assumes that the workbook named "testcompare1.xlsm" is already open in Excel. The call will fail if its not open. To fix this, create another variable (such as myWorkbook2) and set it using Workbooks.Open, then use that as a parameter. It should work then.
• Miriam List: yes the file was just and example to show you. I just wanted to ask for some help on how to run your code from above or how to add the sub and the functions from your code to the button.
• PeterT: @MiriamList - please see if the added code answers your question
• Miriam List: I followed your code. so I added a module and then put the active button on the first sheet and I wanted to compare sheet1 with sheet2 of the same excel file. When I run the code I'm getting Error while compiling custom type not defined at Private Function BuildDataDictionary(ByRef data As Variant, _ Optional ByVal keyColumn As Long = 8) As Dictionary