Code To Highlight What Is In Column AD On Sheet 2 But Not In Column AD on Sheet 1 With K As The Delimiter

[Dazzawm]

I have hidden a lot of columns for clarity.

The code first needs to concentrate on column K. It needs to look at the number on sheet 2 then the corresponding number on sheet 1. It then needs to look at column AD. Any numbers that are in AD on sheet 2 but not in column AD on sheet 1 then the entire row on sheet 1 needs to be highlighted please.

For clarity I have highlighted the 4 different examples a different colour. The data in yellow as you can see the 4 numbers on sheet 2 are listed ok on sheet 1 (next to the corresponding number in K M10200360000001)

With the blue data you can see there is a difference, 2910LMB & 2910RMB (I have left clear) are on sheet 2 but when you look at the data in blue on sheet 1 they are not there so all those rows would need to be highlighted (obviously they would all be clear).

The data in green is fine as they match on sheet 1.

The data in red all the numbers are missing on sheet 1 as they say NYA in all rows so those rows would need to be highlighted.

Its one of those ones where it may be harder to explain than it is to find a solution!

Excel 2010
	K	AD
2	M10200360000001	2906LM
3	M10200360000001	2907RM
4	M10200360000001	2908LMB
5	M10200360000001	2909RMB
6	M10200360000002	2906LM
7	M10200360000002	2906LM
8	M10200360000002	2907RM
9	M10200360000002	2907RM
10	M10200360000002	2908LMB
11	M10200360000002	2910LMB
12	M10200360000002	2910RMB
13	M10200360000002	2909RMB
14	M10200360000003	2906LM
15	M10200360000003	2907RM
16	M10200360000003	2908LMB
17	M10200360000003	2909RMB
18	M10200360000004	2906LM
19	M10200360000004	2907RM
20	M10200360000004	2908LMB
21	M10200360000004	2909RMB
Sheet2

Excel 2010
	K	AD
2	M10200360000001	NYA
3	M10200360000001	NYA
4	M10200360000001	2906LM
5	M10200360000001	2907RM
6	M10200360000001	NYA
7	M10200360000001	NYA
8	M10200360000001	2908LMB
9	M10200360000001	2909RMB
10	M10200360000002	NYA
11	M10200360000002	NYA
12	M10200360000002	2906LM
13	M10200360000002	2907RM
14	M10200360000002	NYA
15	M10200360000002	NYA
16	M10200360000002	2908LMB
17	M10200360000002	2909RMB
18	M10200360000003	NYA
19	M10200360000003	NYA
20	M10200360000003	2906LM
21	M10200360000003	2907RM
22	M10200360000003	NYA
23	M10200360000003	NYA
24	M10200360000003	2908LMB
25	M10200360000003	2909RMB
26	M10200360000004	NYA
27	M10200360000004	NYA
28	M10200360000004	NYA
29	M10200360000004	NYA
30	M10200360000004	NYA
31	M10200360000004	NYA
32	M10200360000004	NYA
33	M10200360000004	NYA
Sheet1

 

[Dazzawm]

No I didn't. But I have now and it seems to have worked. Top man, thanks.

 

[Dazzawm]

I know its been a couple of years since the original post but all of a sudden the code has stopped working. It needs to look at column AE rather than AD now as I have an extra column. I changed everywhere that says AD to AE but its not highlighting the rows where the data differs. Is there anything else that needs to changed in Leiths code please?

 

[Dazzawm]

This was the working code apart from the changes of column (AE)

Option Explicit




Global Dict1 As Object
Global Dict2 As Object




Sub LoadDictionary(ByRef Dict As Object, ByRef Wks As Worksheet)


    Dim cell    As Range
    Dim cx      As Long
    Dim Data()  As Variant
    Dim Key     As String
    Dim rng     As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim X       As Long
    
        If Dict Is Nothing Then
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
        Else
            Dict.RemoveAll
        End If
        
            Set RngBeg = Wks.Range("K2")
            Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
            If RngEnd.Row < RngBeg.Row Then Exit Sub
            
            cx = Wks.Columns("K:AE").Count - 1
            Set rng = Wks.Range(RngBeg, RngEnd)
            
            For Each cell In rng
                Key = Trim(cell.Value)
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        ReDim Data(0)
                        GoSub UpdateData
                        ' Add the Key and Data to this dictionary.
                        Dict.Add Key, Data
                    Else
                        ' Return the Data for this Key.
                        Data = Dict(Key)
                        GoSub UpdateData
                        ' Save the updated Data for this Key.
                        Dict(Key) = Data
                    End If
                End If
            Next cell
           
Exit Sub




UpdateData:
            ' Add this cell's row number to the list of rows to highlight for this Key.
            Data(0) = Data(0) & cell.Row & ","
            
            With cell.Offset(0, cx)
                ' Check if "AD" entry is a duplicate.
                For X = 1 To UBound(Data)
                    If Data(X) = .Value Then
                        Return
                    End If
                Next X
                ' Save the value in column "AD" in element (1) onward if it is not "NYA" nor "NLA".
                If .Value <> "NYA" And .Value <> "NLA" And .Value <> "NDA" And .Value <> "NA" Then
                    ReDim Preserve Data(UBound(Data) + 1)
                    Data(UBound(Data)) = .Value
                End If
            End With
        Return




End Sub




Sub CatDiffFromSupplier()






    Dim cell        As Range
    Dim Cnt         As Long
    Dim cx          As Long
    Dim Data1       As Variant
    Dim Data2       As Variant
    Dim j           As Long
    Dim k           As Long
    Dim Key         As Variant
    Dim n           As Long
    Dim nRows       As Variant
    Dim rng         As Range
    Dim RngBeg      As Range
    Dim RngEnd      As Range
    Dim Wks         As Worksheet
     
        ' Namaes of the worksheets to compare.
        Call LoadDictionary(Dict1, ActiveWorkbook.Worksheets("Sheet1"))
        Call LoadDictionary(Dict2, ActiveWorkbook.Worksheets("Sheet2"))
        
        Set Wks = ActiveWorkbook.Worksheets("Sheet1")
        
        cx = Wks.Columns("K:AE").Count
        
        Application.ScreenUpdating = False
        
            Set RngBeg = Wks.Range("K2")
            Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
            If RngEnd.Row < RngBeg.Row Then Exit Sub
            
            Set rng = Wks.Range(RngBeg, RngEnd)
            
            For Each Key In Dict1.Keys
                Data1 = Dict1(Key)
                Data2 = Dict2(Key)
                Cnt = 1
                
                If VarType(Data2) <> vbEmpty Then
                    ' Check the number of entries is the same.
                    If UBound(Data1) >= UBound(Data2) Then
                        ' Loop through each column "ÄD" entry for Sheet2.
                        For k = 1 To UBound(Data2)
                            ' Check Data1 entries match Data2 entries.
                            For j = 1 To UBound(Data1)
                                If Data1(j) = Data2(k) Then
                                    Cnt = Cnt + 1
                                    Exit For
                                End If
                            Next j
                        Next k
                        
                        ' Was all of Data2 found in Data1?
                        If Cnt < UBound(Data2) Then
                            GoSub HighlightRows
                        End If
                    Else
                        GoSub HighlightRows
                    End If
                End If
            Next Key
            
        Application.ScreenUpdating = True
        
Exit Sub




HighlightRows:
            nRows = Split(Data1(0), ",")
            For n = 0 To UBound(nRows) - 1
                Wks.Cells(nRows(n), "A").Resize(1, cx).Interior.ColorIndex = 3
            Next n
        Return
        
End Sub


Sub Reset()


    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

 

[Worf]

So, I understand that this works for the original setup if AE is replaced back with AD.
I will be back…

 

[Dazzawm]

It seemed to work fine when it was AD but after changing to AE it does not highlight the rows when the data on sheet 1 does not match sheet 2.

 

[Worf]

I moved both columns from AD to AE and also changed the two references in the code.
The two data blocks mentioned at the first post were highlighted as expected.
Would you like a link to my test workbook?

 

[Dazzawm]

If you provide your code I will try it.

 

[Dazzawm]

After a little trial and error I have found something odd. When I first run the code it highlights the incorrect matches as it should. If I put the correct data according to sheet 2 in sheet 1 and run the code again its not highlighted - as it should, but for testing purposes if I put an incorrect number in again and run the code it doesn't get highlighted which it should? Almost as if its a one time code!!

 

[Worf]

Try this version:

Global Dict1 As Object
Global Dict2 As Object


Sub LoadDictionary(ByRef Dict As Object, ByRef Wks As Worksheet)
    Dim cell    As Range, cx      As Long
    Dim Data()  As Variant, Key     As String, rng     As Range
    Dim RngBeg  As Range, RngEnd  As Range, X       As Long
    
        If Dict Is Nothing Then
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
        Else
            Dict.RemoveAll
        End If
            Set RngBeg = Wks.Range("K2")
            Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
            If RngEnd.Row < RngBeg.Row Then Exit Sub
            
            cx = Wks.Columns("K:ae").Count - 1
            Set rng = Wks.Range(RngBeg, RngEnd)
            
            For Each cell In rng
                Key = Trim(cell.Value)
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        ReDim Data(0)
                        GoSub UpdateData
                        Dict.Add Key, Data  ' Add the Key and Data to this dictionary.
                    Else
                        ' Return the Data for this Key.
                        Data = Dict(Key)
                        GoSub UpdateData
                        ' Save the updated Data for this Key.
                        Dict(Key) = Data
                    End If
                End If
            Next cell
           
Exit Sub
UpdateData:
            ' Add this cell's row number to the list of rows to highlight for this Key.
            Data(0) = Data(0) & cell.Row & ","
             With cell.Offset(0, cx)
                ' Check if "AD" entry is a duplicate.
                For X = 1 To UBound(Data)
                    If Data(X) = .Value Then Return
                    
                Next X
                ' Save the value in column "AD" in element (1) onward if it is not "NYA" nor "NLA".
                If .Value <> "NYA" And .Value <> "NLA" And .Value <> "NDA" And .Value <> "NA" Then
                    ReDim Preserve Data(UBound(Data) + 1)
                    Data(UBound(Data)) = .Value
                End If
            End With
        Return
End Sub


Sub CatDiffFromSupplier()
    Dim cell        As Range, Cnt         As Long
    Dim cx          As Long, Data1       As Variant, Data2
    Dim j           As Long, k           As Long, Key, n&, nRows
    Dim rng As Range, RngBeg As Range, RngEnd      As Range, Wks As Worksheet
     
        ' Names of the worksheets to compare.
        Call LoadDictionary(Dict1, ActiveWorkbook.Worksheets("Sheet1"))
        Call LoadDictionary(Dict2, ActiveWorkbook.Worksheets("Sheet2"))
        Set Wks = ActiveWorkbook.Worksheets("Sheet1")
        
        cx = Wks.Columns("K:ae").Count
        
        Application.ScreenUpdating = False
            Set RngBeg = Wks.Range("K2")
            Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
            If RngEnd.Row < RngBeg.Row Then Exit Sub
            Set rng = Wks.Range(RngBeg, RngEnd)
            For Each Key In Dict1.Keys
                Data1 = Dict1(Key)
                Data2 = Dict2(Key)
                Cnt = 1
                
                If VarType(Data2) <> vbEmpty Then
                    ' Check the number of entries is the same.
                    If UBound(Data1) >= UBound(Data2) Then
                        ' Loop through each column "ÄD" entry for Sheet2.
                        For k = 1 To UBound(Data2)
                            ' Check Data1 entries match Data2 entries.
                            For j = 1 To UBound(Data1)
                                If Data1(j) = Data2(k) Then
                                    Cnt = Cnt + 1
                                    Exit For
                                End If
                            Next j
                        Next k
                        ' Was all of Data2 found in Data1?
                        If Cnt < UBound(Data2) + 1 Then GoSub HighlightRows
                        
                    Else
                        GoSub HighlightRows
                    End If
                End If
            Next Key
            
        Application.ScreenUpdating = True
        
Exit Sub
HighlightRows:
            nRows = Split(Data1(0), ",")
            For n = 0 To UBound(nRows) - 1
                Wks.Cells(nRows(n), "A").Resize(1, cx).Interior.ColorIndex = 3
            Next
        Return
End Sub


Sub Reset()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
End Sub

 

[Dazzawm]

Early indications seem to look like it works, thanks. I wil confirm once I give it some more strenuoeus testing.