Highlighting duplicates across all worksheets

[khtanned]

Hi I'm new to this forum and know very little about VBA. I hope to be able to get some help here with my spreadsheet. I have a workbook of 20+ exact similar worksheets. In B6:B100 of each worksheet, I need to automatically highlight any duplicates in that range as well as those across all worksheets. It should also work for any newly added worksheets. Perhaps the "Private Sub Workbook_SheetChange..." function will get it done automatically? It should not highlight blank cells and also automatically undo the highlight when the value in the cell has been deleted or corrected to be unique. I hope my explanation is not confusing. Any help or suggestions would be greatly appreciated. Thank you.

 

[khtanned]

Hi MickG,

Thanks so much for the explanation. As for the Dictionary, Wow, that's really complicated.

So I tested the color worksheet tabs macro and ran into these glitches when entering duplicate values into
B7:B106 (Oh I changed the range in my worksheets from B1:B100 to B7:B106).

1. The active sheet tab wasn't colored despite having a duplicate entry.
2. When the duplicates were individually cleared, the respective sheet tabs still remain colored.
3. I have an existing "Clear" macro that clears data from B7:C106 plus some other
non-congruent cells in the active sheet. When the macro was activated, the tab remained colored.

So I meddled with your original code by adding these 4 lines marked with <<< shown below.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Ws As Worksheet, Dn As Range
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

For Each Ws In Worksheets
Ws.Tab.ColorIndex = xlColorIndexNone <<<
Ws.Range("B7:B106").Interior.ColorIndex = xlNone
Application.ScreenUpdating = True
For Each Dn In Ws.Range("B7:B106")
If Dn.Value <> "" Then
If Not .exists(Dn.Value) Then
.Add Dn.Value, Dn
Ws.Tab.ColorIndex = xlColorIndexNone <<<
Else
.Item(Dn.Value).Interior.Color = vbRed
Dn.Interior.Color = vbRed
ActiveSheet.Tab.Color = 225 <<<
Ws.Tab.Color = 225 <<<
Application.ScreenUpdating = True <<<
End If
End If
Next Dn
Next Ws
End With
End Sub

I'm certainly unsure of what I'm doing but it somehow seems to get around the said glitches. Also, I don't know if that will mess up other things.

There's another thing I need to ask you. Even when I was using your first vba code to highlight duplicates, I sometimes run into this bug : "Runtime error '1004' Unable to set the ColorIndex property of the Interior class"
and this line gets highlighted - Ws.Range("B7:B106").Interior.ColorIndex = xlNone

In every worksheet, there's an existing Worksheet Change by Val macro that stamps the date and time in cell S4 when a (WorkOrder) number is entered in cell G2. I had cell S4 locked so that the date stamp won't be accidentally erased. But in order for the macro to write in cell S4 I had the lines, ActiveSheet.Unprotect "Password" and ActiveSheet Protect "Password" before and after the Now() function.

I later found that it was the ActiveSheet.Protect that triggered the Runtime error '1004'. As long as I have this line in any Sub, be it the "Clear" or the "Sort" macro, it triggers the error. With the ActiveSheet.Protect line remarked (') it runs ok.

What I cannot understand is why the error occurs when "B7:B106" is not locked, whether or not the worksheet is protected. And I need to use the ActiveSheet.UnProtect and Protect lines to have cell S4
locked so that the user does not accidentally erase the date and time.

Is there any way to get around this? Would it be ok to send you my workbook via email?

My apologies for the longwinded message. Hope it's not confusing.

Thank you
khtan

 

[MickG]

Try this code below:-
Below that is an alternative bit of code that you could add to your "Worsheet_Selection Change" Event when you Change "S4" value.
This is instead of protecting the Sheet and just stops anyone actually selecting "S4".

Private [COLOR="Navy"]Sub[/COLOR] Workbook_SheetChange(ByVal Sh [COLOR="Navy"]As[/COLOR] Object, ByVal Target [COLOR="Navy"]As[/COLOR] Range)
 [COLOR="Navy"]Dim[/COLOR] Ws [COLOR="Navy"]As[/COLOR] Worksheet, Dn [COLOR="Navy"]As[/COLOR] Range, Q [COLOR="Navy"]As[/COLOR] Variant
 [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
 .CompareMode = vbTextCompare
Application.ScreenUpdating = False

 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ws [COLOR="Navy"]In[/COLOR] Worksheets
    Ws.Tab.ColorIndex = xlColorIndexNone '[COLOR="Green"][B]<<<[/B][/COLOR]
    Ws.Range("B7:B106").Interior.ColorIndex = xlNone
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ws.Range("B7:B106")
            [COLOR="Navy"]If[/COLOR] Dn.Value <> "" [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                    .Add Dn.Value, Array(Dn, Ws)
                [COLOR="Navy"]Else[/COLOR]
                    Q = .Item(Dn.Value)
                        Q(0).Interior.Color = vbRed
                        Dn.Interior.Color = vbRed
                        Ws.Tab.Color = 225
                        Q(1).Tab.Color = 225
                    .Item(Dn.Value) = Q
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dn
 [COLOR="Navy"]Next[/COLOR] Ws
 
Application.ScreenUpdating = True '[COLOR="Green"][B]<<<[/B][/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Private [COLOR="Navy"]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
   [COLOR="Navy"]If[/COLOR] Target.Address = Range("S4").Address [COLOR="Navy"]Then[/COLOR]
       Target.Offset(1, 0).Select
   [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[khtanned]

Hi MickG,

It works nicely!! You're a lifesaver! Thanks a trillion!!

khtan

 

[MickG]

You're welcome