VBA-Compare two lists to find differences and new records

[Beginer1026]

Hi,

How can I modify the code so that it can also compare columns C and H ("Nature") and highlight the difference (i.e. cell H4)...just like cell G10 and I15 ?

Compare and Find Differences.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Document No.	Amount	Nature	Company		Document No.	Amount	Nature	Company
2	220537-W	13,999.50	ABC	Company A		220537-W	$13,999.50	ABC	Company A
3	220538-W	3,840.00	XYZ	Company B		220538-W	$3,840.00	XYZ	Company B
4	220539-W	1,597.00	ABC	Company B		220539-W	$1,597.00	XYZ	Company B
5	220542-W	810.69	ZZZ	Company B		220542-W	$810.69	ZZZ	Company B
6	220543-W	2,800.00	ZZZ	Company B		220543-C	$2,800.00	ZZZ	Company B
7	220544-W	604.06	ZZZ	Company C		220544-W	$604.06	ZZZ	Company C
8	220547-W	2,752.25	XYZ	Company M		220545-W	$40,046.40	ZZZ	Company C
9	220611-C	2,880.00	ZZZ	Company GGG		220546-W	$14,400.00	XYZ	Company P
10	220612-W	2,225.00	ABC	Company EGG		220547-W	$2,752.28	XYZ	Company M
11						220548-C	$500.00	XYZ	Company BBC
12						220549-C	$1,920.00	XYZ	Company RET
13						220609-C	$4,960.00	XYZ	Company KL
14						220610-C	$3,594.88	XYZ	Company MBC
15						220611-C	$2,880.00	ZZZ	Company DGG
16						220612-W	$2,225.00	ABC	Company EGG
17
Sheet1

Sub CompareList()
    
    Application.ScreenUpdating = True
    Dim DocNo As Range
    Dim RngList As Object
    Dim rng As Range
    
    Set RngList = CreateObject("Scripting.Dictionary")
    Dim FoundDocNo As Range
    Dim LastRow2 As Long
    Dim lastRow As Long
    
    lastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each DocNo In Sheets("Sheet1").Range("F2:F" & lastRow)
        Set FoundDocNo = Sheets("Sheet1").Range("A:A").Find(DocNo, LookIn:=xlValues, lookat:=xlWhole)
        If Not FoundDocNo Is Nothing Then
            For Each rng In Sheets("Sheet1").Range("A" & FoundDocNo.Row & ":D" & FoundDocNo.Row)
                If Not RngList.Exists(rng.Value) Then
                    RngList.Add rng.Value, Nothing
                End If
            Next rng
            For Each rng In Sheets("Sheet1").Range("F" & DocNo.Row & ":I" & DocNo.Row)
                If Not RngList.Exists(rng.Value) Then
                    rng.Interior.ColorIndex = 6
                End If
            Next rng
        Else
            With Sheets("Sheet1").Range("F" & DocNo.Row & ":I" & DocNo.Row)
                .Interior.ColorIndex = 4
            End With
'           DocNo.Interior.ColorIndex = 4
        End If
    Next DocNo
    
    LastRow2 = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each DocNo In Sheets("Sheet1").Range("a2:a" & lastRow)
        Set FoundDocNo = Sheets("Sheet1").Range("f:f").Find(DocNo, LookIn:=xlValues, lookat:=xlWhole)
        If FoundDocNo Is Nothing Then
            With Sheets("Sheet1").Range("A" & DocNo.Row & ":D" & DocNo.Row)
                .Interior.ColorIndex = 8
            End With
'            DocNo.Interior.ColorIndex = 8
        End If
    Next DocNo
End Sub

Thanks in advance !

 

[smozgur]

Welcome to the MrExcel Message Board!

You need to reset the dictionary object to remove the previously added values, RngList. You can add the following line in the first loop:

        If Not FoundDocNo Is Nothing Then
            RngList.RemoveAll

Alternatively, I would use the following code without using multiple loops and a Dictionary object that would lead to false positive results in the way using it to find the matches in the existing code.

Sub CompareListAlternative()
Dim sht As Worksheet
Dim rngA As Range
Dim rngF As Range
Dim rw As Range
Dim cll As Range
Dim fnd As Range

    Set sht = ActiveSheet
    Set rngA = sht.Range("A1").CurrentRegion
    Set rngA = rngA.Offset(1).Resize(rngA.Rows.Count - 1)
    
    Set rngF = sht.Range("F1").CurrentRegion
    Set rngF = rngF.Offset(1).Resize(rngF.Rows.Count - 1)
    
    rngA.Rows.Cells.Interior.Pattern = xlNone
    rngF.Rows.Cells.Interior.ColorIndex = 4
    
    For Each rw In rngA.Rows
        Set fnd = rngF.Columns(1).Find(rw.Cells(1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        If fnd Is Nothing Then
            rw.Interior.ColorIndex = 8
        Else
            fnd.Resize(, rngF.Columns.Count).Interior.Pattern = xlNone
            For Each cll In rw.Cells
                If fnd.Cells(, cll.Column) <> cll.Value Then
                    fnd.Cells(, cll.Column).Interior.ColorIndex = 6
                End If
            Next cll
        End If
    Next rw

End Sub

Result:

Book1
	A	B	C	D	E	F	G	H	I
1	Document No.	Amount	Nature	Company		Document No.	Amount	Nature	Company
2	220537-W	13999.50	ABC	Company A		220537-W	13999.50	ABC	Company A
3	220538-W	3840.00	XYZ	Company B		220538-W	3840.00	XYZ	Company B
4	220539-W	1597.00	ABC	Company B		220539-W	1597.00	XYZ	Company B
5	220542-W	810.69	ZZZ	Company B		220542-W	810.69	ZZZ	Company B
6	220543-W	2800.00	ZZZ	Company B		220543-C	2800.00	ZZZ	Company B
7	220544-W	604.06	ZZZ	Company C		220544-W	604.06	ZZZ	Company C
8	220547-W	2752.25	XYZ	Company M		220545-W	40046.40	ZZZ	Company C
9	220611-C	2880.00	ZZZ	Company GGG		220546-W	14400.00	XYZ	Company P
10	220612-W	2225.00	ABC	Company EGG		220547-W	2752.28	XYZ	Company M
11						220548-C	500.00	XYZ	Company BBC
12						220549-C	1920.00	XYZ	Company RET
13						220609-C	4960.00	XYZ	Company KL
14						220610-C	3594.88	XYZ	Company MBC
15						220611-C	2880.00	ZZZ	Company DGG
16						220612-W	2225.00	ABC	Company EGG
Sheet1

 

[Beginer1026]

Welcome to the MrExcel Message Board!

You need to reset the dictionary object to remove the previously added values, RngList. You can add the following line in the first loop:

        If Not FoundDocNo Is Nothing Then
            RngList.RemoveAll

Alternatively, I would use the following code without using multiple loops and a Dictionary object that would lead to false positive results in the way using it to find the matches in the existing code.

Sub CompareListAlternative()
Dim sht As Worksheet
Dim rngA As Range
Dim rngF As Range
Dim rw As Range
Dim cll As Range
Dim fnd As Range

    Set sht = ActiveSheet
    Set rngA = sht.Range("A1").CurrentRegion
    Set rngA = rngA.Offset(1).Resize(rngA.Rows.Count - 1)
   
    Set rngF = sht.Range("F1").CurrentRegion
    Set rngF = rngF.Offset(1).Resize(rngF.Rows.Count - 1)
   
    rngA.Rows.Cells.Interior.Pattern = xlNone
    rngF.Rows.Cells.Interior.ColorIndex = 4
   
    For Each rw In rngA.Rows
        Set fnd = rngF.Columns(1).Find(rw.Cells(1).Value, LookIn:=xlValues, LookAt:=xlWhole)
        If fnd Is Nothing Then
            rw.Interior.ColorIndex = 8
        Else
            fnd.Resize(, rngF.Columns.Count).Interior.Pattern = xlNone
            For Each cll In rw.Cells
                If fnd.Cells(, cll.Column) <> cll.Value Then
                    fnd.Cells(, cll.Column).Interior.ColorIndex = 6
                End If
            Next cll
        End If
    Next rw

End Sub

Result:

Book1
	A	B	C	D	E	F	G	H	I
1	Document No.	Amount	Nature	Company		Document No.	Amount	Nature	Company
2	220537-W	13999.50	ABC	Company A		220537-W	13999.50	ABC	Company A
3	220538-W	3840.00	XYZ	Company B		220538-W	3840.00	XYZ	Company B
4	220539-W	1597.00	ABC	Company B		220539-W	1597.00	XYZ	Company B
5	220542-W	810.69	ZZZ	Company B		220542-W	810.69	ZZZ	Company B
6	220543-W	2800.00	ZZZ	Company B		220543-C	2800.00	ZZZ	Company B
7	220544-W	604.06	ZZZ	Company C		220544-W	604.06	ZZZ	Company C
8	220547-W	2752.25	XYZ	Company M		220545-W	40046.40	ZZZ	Company C
9	220611-C	2880.00	ZZZ	Company GGG		220546-W	14400.00	XYZ	Company P
10	220612-W	2225.00	ABC	Company EGG		220547-W	2752.28	XYZ	Company M
11						220548-C	500.00	XYZ	Company BBC
12						220549-C	1920.00	XYZ	Company RET
13						220609-C	4960.00	XYZ	Company KL
14						220610-C	3594.88	XYZ	Company MBC
15						220611-C	2880.00	ZZZ	Company DGG
16						220612-W	2225.00	ABC	Company EGG
Sheet1

Just tried adding RngList.RemoveAll to my code and it worked perfectly !
I will look into and try the code you suggested late, thanks a lot!