Update VBA Looping Code that compares two spreadsheets and looks for differences however has duplicate driving cell

[tvjanes45]

Thanks advance to my excel experts. You all are the best and amazing.

So I am developing this tool that will compare two spreadsheets and identify any differences noted on sheet 2 vs sheet 1 based on the USSGL account column. So I have a working VBA code however, I have added two new sheets to the workbook and these sheets contain duplicate USSGL accounts and whenever a duplicate is found it returns and error message saying that some of the columns are "differences/ changes" when comparing the two sheets, which is incorrect. The duplicate USSGL is on both spreadsheets so it should not highlight the column as an change.

Here is an example for the issue:

Sheet 1
[TABLE="width: 500"]
<tbody>[TR]
[TD]USSGL[/TD]
[TD]Account Title[/TD]
[TD]Begin/END[/TD]
[TD]D/C[/TD]
[TD]BEA Cat[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]412200[/TD]
[TD]Authority Adjusted for Interest [/TD]
[TD]B[/TD]
[TD]D/C[/TD]
[TD]M[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]416600[/TD]
[TD]Allocations of Realized Authority [/TD]
[TD]B[/TD]
[TD]D/C[/TD]
[TD]M[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]416600[/TD]
[TD]Allocations of Realized Authority [/TD]
[TD]B[/TD]
[TD]D/C[/TD]
[TD]D[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Sheet 2
[TABLE="width: 500"]
<tbody>[TR]
[TD]USSGL[/TD]
[TD]Account Title[/TD]
[TD]Begin/END[/TD]
[TD]D/C[/TD]
[TD]BEA Cat[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]412200[/TD]
[TD]Authority Adjusted for Interest [/TD]
[TD]B[/TD]
[TD]D/C[/TD]
[TD]M[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]416600[/TD]
[TD]Allocations of Realized Authority [/TD]
[TD]B[/TD]
[TD]D/C[/TD]
[TD]M[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]416600[/TD]
[TD]Allocations of Realized Authority [/TD]
[TD]B[/TD]
[TD]D/C[/TD]
[TD]D[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


The code is showing that the "D" on sheet 2 is a change when its not-- It's on Sheet 1. Nothing changed between both sheets.

Here is the code I'm using:

Sub Compare_Values_SF133()
Application.ScreenUpdating = False
Dim GL As Range, RngList As Object, rng As Range
Set RngList = CreateObject("Scripting.Dictionary")
Dim foundGL As Range
Dim mydiffs As Integer
Dim LastRow2 As Long
Dim LastRow As Long
LastRow = Sheets("CurrentQtr_SF133").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
For Each GL In Sheets("CurrentQtr_SF133").Range("A2:A" & LastRow)
Set foundGL = Sheets("PriorQtr_SF133").Range("A:A").Find(GL, LookIn:=xlValues, lookat:=xlWhole)
If Not foundGL Is Nothing Then
For Each rng In Sheets("PriorQtr_SF133").Range("A" & foundGL.row & ":Z" & foundGL.row)
If Not RngList.Exists(rng.Value) Then
RngList.Add rng.Value, Nothing
End If
Next rng
For Each rng In Sheets("CurrentQtr_SF133").Range("A" & GL.row & ":Z" & GL.row)
If Not RngList.Exists(rng.Value) Then
rng.Interior.ColorIndex = 41
mydiffs = mydiffs + 1
End If
Next rng
Else
GL.EntireRow.Interior.ColorIndex = 31
mydiffs = mydiffs + 1
End If
Next GL
LastRow2 = Sheets("PriorQtr_SF133").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
For Each GL In Sheets("PriorQtr_SF133").Range("A2:A" & LastRow)
Set foundGL = Sheets("CurrentQtr_SF133").Range("A:A").Find(GL, LookIn:=xlValues, lookat:=xlWhole)
If foundGL Is Nothing Then
GL.EntireRow.Interior.ColorIndex = 22
mydiffs = mydiffs + 1

End If
Next GL

MsgBox mydiffs & " differences found", vbInformation

End Sub


Thanks in advance for all of your help..

 

[sijpie]

Hi tvjanes45, please next time wrap your code in code tags (see example in red below) to make it easier to read.

What is happening with your code is that in sheet 2 lines 3 & 4 are nearly identical. The code comes to line 4 in sheet1, and starts looking for the value 416600 in column A of sheet2. it finds it in row 3. Then it starts comparing the row values and when it comes to column E it sees an 'M' where the row 4 of Sheet 1 has a 'D'. So it colours the 'D'.

There are a number of things (apart from solving this issue) that you can do to make your code more efficient if the number of rows are very large.