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.

 

[Kamolga]

You can try this

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Declare Variable
Dim myCell As Range
    'Define Range
    Set Target = Sh.Range("B6:B100")
    'Loop each cell from row 6 to 100 in column 2
    For Each myCell In Target
        'And highlght duplicates in red
        If WorksheetFunction.CountIf(Target, myCell.Value) > 1 Then
           myCell.Interior.ColorIndex = 3       [LEFT][COLOR=#222222][FONT=Tahoma]          'else no color[/FONT][/COLOR][/LEFT]
          Else
            With myCell.Interior
                   .Pattern = xlNone
                   .TintAndShade = 0
                   .PatternTintAndShade = 0
            End With
        End If
    Next
End Sub
<strike></strike>

 

[khtanned]

Hi Kamolga,

Thank you very much for the code. It works only for each worksheet singly. That is to say if I entered the number "123" twice or more in the specified range in Sheet1, these duplicate entries do automatically get highlighted in red.
(I could do that with Conditional Formatting) However if I also have a single entry of "123" in Sheets 2, 3, 5, 7, 8, for example, these duplicate entries are not highlighted. I need to have every duplicate entry to be highlighted across the entire workbook.
Hope that's not too difficult to code. Thank you.

 

[MickG]

Try this in "ThisworkBook" module.

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
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ws [COLOR="Navy"]In[/COLOR] Worksheets
    Ws.Range("B1:B100").Interior.Color = xlNone
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ws.Range("B1:B100")
      [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, Dn
        [COLOR="Navy"]Else[/COLOR]
            .Item(Dn.Value).Interior.Color = vbYellow
            Dn.Interior.Color = vbYellow
        [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] Ws
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[khtanned]

Thanks very much MickG! It works, however for some reason, when the very first duplicate entry is entered, cells B1 to B100 of every worksheet is filled in light blue color. And it stays that way
even when all entries were deleted. My apologies for the delayed response. Thanks again to you and Kamolga.

 

[MickG]

You're welcome
Re "Light blue Colour". Maybe :- Check for conditional formatting

 

[khtanned]

Hi MickG,

I am using your vba code in my Excel spreadsheet and it works as intended. However, as there are many worksheets in one workbook, I have to go through each one to look for the highlighted duplicates. Would it be possible to modify the code such that it also colors the worksheet tab (any color, Red will do just fine) if there are duplicates in that sheet. In other words, if there are duplicates in sheets 1, 2, 7 and 24, the sheet tabs of worksheets 1, 2, 7 and 24 will be colored red.

Thank you so much for your help! Truly appreciated!!
khtan

 

[MickG]

Try this:-

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
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Ws [COLOR="Navy"]In[/COLOR] Worksheets
   Ws.Tab.Color = xlNone
    Ws.Range("B1:B100").Interior.Color = xlNone
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Ws.Range("B1:B100")
      [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, Dn
        [COLOR="Navy"]Else[/COLOR]
            .Item(Dn.Value).Interior.Color = vbYellow
            Dn.Interior.Color = vbYellow
            Ws.Tab.Color = 255
        [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] Ws
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[khtanned]

Thank you very much, MickG! I am just reading this right now. I'll try it out in a while.

Oh, may I also ask what the following lines of your code does?
If Dn.Value <> "" Then
If Not .exists(Dn.Value) Then
.Add Dn.Value, Dn

Thank you so much again!!
khtan

 

[MickG]

You're welcome
If Dn.Value <> "" Then := This is just checking to make sure each cell to be use is not empty

If Not .exists(Dn.Value) Then
.Add Dn.Value, Dn
The above lines are to Start adding unique values to the "Dictionary Object". See below.

http://www.snb-vba.eu/VBA_Dictionary_en.html