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]

I did try that but it doesn't work right, it's highlighted rows that it shouldn't.

 

[Leith Ross]

Hello Darren,

After looking at Mark's post, I found his code is using only unique values from "Sheet2". My code allowed for duplicates. This probably the reason for lines being highlighted that should not have been.

I have made a change to my macro code to not allow duplicate values. Using Mark's workbook to test the amended code, the results were identical to his, even when changes where made to the data to create errors. Therefore, I am confident this amended code will function for you just like Mark's. Test it and let me know the results.

Amended Code to Highlight Rows

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
    
        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:AD").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 & ","
            
            ' Check if "AD" entry is a duplicate.
            If VarType(Application.Match(Cell.Offset(0, cx), Data, 0)) = vbError Then
                ' Save the value in column "AD" in element (1) onward if it is not "NYA".
                If Cell.Offset(0, cx).Value <> "NYA" Then
                    ReDim Preserve Data(UBound(Data) + 1)
                    Data(UBound(Data)) = Cell.Offset(0, cx).Value
                End If
            End If
        Return


End Sub


Sub HighlightData()


    Dim Cell        As Range
    Dim cx          As Long
    Dim Data1       As Variant
    Dim Data2       As Variant
    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
     
        Call LoadDictionary(Dict1, ThisWorkbook.Worksheets("Sheet1"))
        Call LoadDictionary(Dict2, ThisWorkbook.Worksheets("Sheet2"))
        
        Set Wks = ThisWorkbook.Worksheets("Sheet1")
        
        cx = Wks.Columns("K:AD").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 Dict2.Keys
                Data1 = Dict1(Key)
                Data2 = Dict2(Key)
                If VarType(Data1) <> vbEmpty Then
                    ' Check if entires are in the same order.
                    If UBound(Data1) = UBound(Data2) Then
                        For k = 1 To UBound(Data2)
                            If Data1(k) <> Data2(k) Then
                                GoSub HighlightRows
                                Exit For
                            End If
                        Next k
                    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), "K").Resize(1, cx).Interior.ColorIndex = 6
            Next n
        Return
        
End Sub

P.S. Thanks Mark

 

[MARK858]

P.S. Thanks Mark

Really the thanks go to Worf as I just amended his code to try and meet the OP's requirement. Hopefully your new code does give Daz the results he wants in the larger workbook because if the code I posted is taking 15 mins for 110,000 rows then it will be painful for....

Btw I will use this on files of 300000 rows

P.S. note to self... must get better with the Scripting Dictionary.

 

[Dazzawm]

Thanks leith. I ran this code and I got a run time error '13' - Type mismatch. When I debugged it pointed to the row

If VarType(Application.Match(Cell.Offset(0, cx), Data, 0)) = vbError Then

Also I would want to add this to my personal macro workbook, will this be possible with this code or does it need to be added to a module within the workbook I am using it on?

 

[Leith Ross]

Hello Darren,

You should provide a link to a larger sample workbook or to a copy of the workbook you are actually using. there is no obvious reason for this error.

I can change the macro code to run from your personal.xls workbook.

 

[Dazzawm]

Hello Darren,

You should provide a link to a larger sample workbook or to a copy of the workbook you are actually using. there is no obvious reason for this error.

I can change the macro code to run from your personal.xls workbook.

Shall I email the full file I am using it on? On dropbox it as its about 22mb?

 

[Leith Ross]

Hello Darren,

Thank you for emailing the original workbook to me. I also want to thank Worf and Mark858 for their insights into this problem.

The macro now highlights the data the same as Worf's macro and can used in your Personal workbook. This macro compares and highlights the data in a few seconds instead of a few minutes.

Here is the new code and a link to the workbook.

Compare and Highlight Columns.xlsb


Module1 Code

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
    
        If Dict Is Nothing Then
            Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare
        Else
            Dict.RemoveAll
        End If
        
            ' Find the last in column "K" with a value.
            Set RngBeg = Wks.Range("K2")
            Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)
            
            ' Exit if there is no data in column "K".
            If RngEnd.Row < RngBeg.Row Then
                MsgBox "Worksheet '" & Wks.Name & "' has No MAM Identifiers in column ""K""", vbCritical
                Exit Sub
            End If
            
            ' cx is the offset from column "K" to column "AD".
            cx = Wks.Columns("K:AD").Count - 1
            
            ' Set the range from "K2" to the last cell with a value in column "K".
            Set Rng = Wks.Range(RngBeg, RngEnd)
            
            ' Create a list of unique values in the range for this worksheet.
            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" if it is not "NYA" nor "NLA" starting with element (1).
                If .Value <> "NYA" And .Value <> "NLA" Then
                    ReDim Preserve Data(UBound(Data) + 1)
                    Data(UBound(Data)) = .Value
                End If
            End With
        Return




End Sub




Sub HighlightData()


    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, Sheet1)
        Call LoadDictionary(Dict2, Sheet2)
        
        Set Wks = Sheet1
        
        cx = Wks.Columns("K:AD").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
                MsgBox "Worksheet '" & Wks.Name & "' has No MAM Identifiers in column ""K""", vbCritical
                Exit Sub
            End If
            
            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), "K").Resize(1, cx).Interior.ColorIndex = 6
            Next n
        Return
        
End Sub

 

[Dazzawm]

Thanks Leith, I can't thank you enough for all your time and efforts. I can't believe it completes in about 10 seconds.

Thanks also goes to worf who got the ball rolling and to marks input.

 

[MARK858]

Just want to say thanks to Leith...
A) for the code.... nice one
and
B) for putting in just enough comments so I understand what the code is doing and so helping my learning curve.

Thanks again

 

[Dazzawm]

Hi Leith, just tried running the code from the personal workbook and it come up with a compile error, variable not defined?

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