0

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!

edsaniti
  • 3
  • 2

0 Answers0