Return to Revisions

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