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]

OK thanks, will do asap, although sheets 1 and 2 do have different headers but k and ad have the same. Is this a problem?

 

[Dazzawm]

For some reason it wouldn't let me put the results in here so I have put the file in dropbox below. When I ran worfs code it coloured all the rows it shouldn't and the rows it should have coloured were left clear.

https://www.dropbox.com/s/8bj3lcqy1hrtae2/Book1.xlsx?dl=0

Actually the bottom set of rows were coloured correctly as none of the numbers on sheet 2 were there as they all contained NYA.

 

[MARK858]

Try the attached and report back. Please note I did change the headers in Sheet2 column K and AD to match Sheet1.

https://app.box.com/s/wfdo23e6xwqnxbjk969f22dqge8raiua

 

[Dazzawm]

By jove I think you cracked it. There's no way around the headers having to match? Because sheet 1 and 2 will be different. If its not possible then don't worry I can get round that, I'm just glad we have got a solution. I will have to double check tomorrow at work but all looks good.

Thanks again Mark and Worf but watch this space!!

 

[MARK858]

There's no way around the headers having to match?

Not that I can think of, that is what advanced filter is based on (try it without them matching and see what happens).

For anyone who can't download the workbook in post #23 the amended code used is below...

Sub Sat()
    Dim r As Range, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, _
        ws4 As Worksheet, i%, j%, problem As Boolean, vr As Range, k%, m%
    Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2")
    Set ws3 = Sheets("sheet3"): Set ws4 = Sheets("sheet4")
    ws2.[af1] = ws2.[k1]                                                    ' criteria range
    ws3.Cells.ClearContents
    ws3.Cells.ClearFormats
    ws2.[af2] = ""
    ws2.[k:k].AdvancedFilter xlFilterCopy, ws2.[af1:af2], ws3.[a1], True    ' unique values
    For j = 2 To ws3.Range("a" & Rows.Count).End(xlUp).Row
        problem = 0
        ws2.[af2] = ws3.Cells(j, 1)
        ws3.[b:z].ClearContents
        ws3.[b:z].ClearFormats
        ws2.[k:ad].AdvancedFilter xlFilterCopy, ws2.[af1:af2], ws3.[b1], False    ' to Sheet3
        ws4.Cells.ClearContents
        ws1.[k:ad].AdvancedFilter xlFilterCopy, ws2.[af1:af2], ws4.[b1], False    ' to Sheet4
        For i = 2 To ws3.Range("u" & Rows.Count).End(xlUp).Row
            Set r = ws4.[u:u].Find(ws3.Cells(i, "u"), , xlValues)
            If r Is Nothing Then problem = 1
        Next
        If problem Then
            ws1.[k:k].AutoFilter 1, ws3.Cells(i - 1, "b")
            Set vr = Intersect(ws1.UsedRange, ws1.[k:k].SpecialCells(xlCellTypeVisible))
            For k = 1 To vr.Areas.Count
                If k = 1 Then
                    For m = 2 To vr.Areas(k).Rows.Count
                        vr.Areas(k).Rows(m).EntireRow.Interior.Color = RGB(150, 180, 200)    ' highlight
                    Next
                Else
                    For m = 1 To vr.Areas(k).Rows.Count
                        vr.Areas(k).Rows(m).EntireRow.Interior.Color = RGB(150, 180, 200)    ' highlight
                    Next
                End If
            Next
        End If
        ws1.[k:k].AutoFilter
    Next
End Sub

 

[Dazzawm]

I did try it with different headers and the results were all over the place, like I say I can work round that but if you or worf can think of a way round then please let me know.

Btw I will use this on files of 300000 rows will this cause a problem or just take a while?

Thanks again.

 

[MARK858]

You shouldn't have any issues other than the time taken with versions later than 2007. Make sure that you turn off Screenupdating because the code will take some time to run (I have ran it on 12000 + rows and it took 1.24 seconds with Screenupdating still on and 887 milliseconds with it off).

I can work round that but if you or worf can think of a way round then please let me know.

As I have stated Advanced Filter needs/uses the headers so there isn't away around it all the time we are using it.
Why not just change the Sheet2 headers at the start of the code when you run it? after all it is the same 2 cells each time, then if you really need to change them back at the end of the code.

 

[Leith Ross]

Hello Darren,

This code will highlight the rows on "Sheet1" that do not match with the order of the rows on "Sheet2" for the same the in columns "K" and "AD". The code starts with row 2 in both columns "K" and "AD" on both sheets.

Add this code to a new VBA Module in your workbook. This code does not care if the data is grouped as you have it in column "K". Run the macro HighlightData.

Here is the module macro 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
        
            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.
            Data(0) = Data(0) & Cell.Row & ","
            ' Save the value in column "AD" in (1) 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
        Return


End Sub


Sub HighlightData()


    Dim Addx        As Variant
    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 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:
            Addx = Split(Data1(0), ",")
            For n = 0 To UBound(Addx) - 1
                Wks.Cells(Addx(n), "K").Resize(1, cx).Interior.ColorIndex = 6
            Next n
        Return
        
End Sub

 

[Dazzawm]

You shouldn't have any issues other than the time taken with versions later than 2007. Make sure that you turn off Screenupdating because the code will take some time to run (I have ran it on 12000 + rows and it took 1.24 seconds with Screenupdating still on and 887 milliseconds with it off).



As I have stated Advanced Filter needs/uses the headers so there isn't away around it all the time we are using it.
Why not just change the Sheet2 headers at the start of the code when you run it? after all it is the same 2 cells each time, then if you really need to change them back at the end of the code.

I just ran it at work and 110,000 rows took 15 mins to complete, although the PC isn't that powerful. It does what I need and I thank you all.

 

[MARK858]

See how Leith's code does, it should be quicker.