VBA Script which compares two sheets and returns unique values in a new sheet - automation

Question

I created a VBA Script which compares a sheet named "New Data" and a sheet named "Old Data" to return only rows with a column differing. I created this in order to find back dating which occurs from time to time, so the two sheets "New Data" and "Old Data" should be identical with 1-5 differences, sometimes they add a new row, sometimes they take one of the old data and change the value attached to it. This is why I have it checking as unique rows, its fine if column a-y is identical but once column z differs then its a unique row.
Please see code below:
Sub CompareSheets()
'Declare variables for the two sheets
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
'Set the variables to the appropriate sheets
Set sheet1 = ThisWorkbook.Sheets("New Data")
Set sheet2 = ThisWorkbook.Sheets("Old Data")
'Declare a variable for the last row in each sheet
Dim lastRow1 As Long
Dim lastRow2 As Long
'Set the last row variables to the last used row in each sheet
lastRow1 = sheet1.Cells(sheet1.Rows.Count, "A").End(xlUp).Row
lastRow2 = sheet2.Cells(sheet2.Rows.Count, "A").End(xlUp).Row
'Declare a variable for the first empty row in a new sheet
Dim nextRow As Long
'Create a new sheet to hold the unique rows
ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = "Unique Rows"
'Set the first empty row variable to the first row of the new sheet
nextRow = 1
' Create a dictionary object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
' Add the data from sheet2 to the dictionary
Dim key As String
For row2 = 2 To lastRow2
key = ""
For col = 1 To sheet2.Cells(1, sheet2.Columns.Count).End(xlToLeft).Column
key = key & sheet2.Cells(row2, col)
Next col
dict.Add key, row2
Next row2
' Turn off screen updating and calculation during execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Loop through each row in sheet1
For row1 = 2 To lastRow1
key = ""
'Create a key for the current row
For col = 1 To sheet1.Cells(1, sheet1.Columns.Count).End(xlToLeft).Column
key = key & sheet1.Cells(row1, col)
Next col
'Check if the key exists in the dictionary
If Not dict.Exists(key) Then
For col = 1 To sheet1.Cells(1, sheet1.Columns.Count).End(xlToLeft).Column
ThisWorkbook.Sheets("Unique Rows").Cells(nextRow, col).Value = sheet1.Cells(row1, col).Value
Next col
nextRow = nextRow + 1
End If
Next row1
'Turn on screen updating and calculation
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I've had this script work and give me unique variables from time to time but in some cases it gives me an error: Run-Time Error '457': That key is already associated with an element of this collection. I've received one other error Run-Time Error '1004' but that's only when Unique Rows sheet already exists, if I delete it would fix this issue. Can you please assist on having this code run smoothly without error?
Thank you, I appreciate your time and effort!