VBA: Find duplicates in Sheet1 + highlight duplicates on other sheets ONLY

[just_bri]

I have a workbook with multiple worksheets.

Sheet1 (cells B4:B54) has random names in it. Sheets 2, 3, etc. have random names as well, also entered in cells B4:B54, like so:

I need a VBA/macro that does the following:

1. If ANY names on Sheet1 are found on the other sheets, then go to the other sheets and highlight the duplicates in green.
2. NOTHING is supposed to be highlighted on Sheet1 itself: Sheet1 is purely for comparison purposes.

I can't find the perfect code anywhere. The code below looked great at first, but it highlights every duplicate on every sheet, even Sheet1. And when I try creating code on my own, I get a ton of runtime errors because I don't understand VBA that well.

Please help. Thanks in advance.

'THIS CODE DOES NOT WORK; IT HIGHLIGHTS EVERY DUP EVEN ON SHEET1
'CODE TAKEN FROM: https://www.reddit.com/r/excel/comments/3ky92o/how_to_highlight_duplicates_across_an_entire/
Sub ColorDuplicates()
Dim w As Integer
Dim c As Range
Dim z As Integer
Application.ScreenUpdating = False
For Each

For w = 1 To ThisWorkbook.Worksheets.Count
    For Each c In Sheets(w).Range("B4:B34" & Sheets(w).UsedRange.Rows.Count)
        For z = w + 1 To ThisWorkbook.Worksheets.Count
            If Not Sheets(z).Range("B4:B34" & Sheets(z).UsedRange.Rows.Count).Find(c, LookAt:=xlWhole) Is Nothing Then
                ColorAll c, Sheets(z)
                ColorAll c, Sheets(w)
            End If
        Next z
    Next c
Next w
Application.ScreenUpdating = True
End Sub
Sub ColorAll(Value As Variant, WS As Worksheet)
Dim Finder As Range
Dim FirstAddress
Set Finder = WS.Range("B4:B34" & WS.UsedRange.Rows.Count).Find(Value, LookAt:=xlWhole)
If Not Finder Is Nothing Then
    FirstAddress = Finder.Address
    Do
        Finder.Font.Color = RGB(0, 176, 80)
        Set Finder = Finder.FindNext(Finder)
    Loop While Not Finder Is Nothing And Finder.Address <> FirstAddress
End If
End Sub
Sub ClearColors()
For Each w In ThisWorkbook.Worksheets
    w.Range("B4:B34" & w.UsedRange.Rows.CountLarge).Interior.ColorIndex = xlNone
Next w
End Sub

 

[just_bri]

UPDATE: I tinkered with it a bit, and somehow was able to solve it! It works now! I've shared the revised code below; hopefully I can help someone else for once.

NOTE: I updated the code so it will also change the font color back to black (in case I add/remove anything from Sheet1)...so it essentially "resets" the code before it runs again.

Sub ColorDuplicates()
'ORIGINAL CODE FROM: https://www.reddit.com/r/excel/comments/3ky92o/how_to_highlight_duplicates_across_an_entire/
Dim w As Integer
Dim c As Range
Dim z As Integer
Application.ScreenUpdating = False

Call ChangeBackToBlack

For w = 2 To ThisWorkbook.Worksheets.Count
    For Each c In Sheets("Sheet1").Range("B4:B34" & Sheets(w).UsedRange.Rows.CountLarge)
        For z = w + 1 To ThisWorkbook.Worksheets.Count
            If Not Sheets(z).Range("B4:B34" & Sheets(z).UsedRange.Rows.CountLarge).Find(c, LookAt:=xlWhole) Is Nothing Then
                ColorAll c, Sheets(z)
                ColorAll c, Sheets(w)
            End If
        Next z
    Next c
Next w
Application.ScreenUpdating = True
End Sub
Sub ColorAll(Value As Variant, ws As Worksheet)
Dim Finder As Range
Dim FirstAddress
Set Finder = ws.Range("B4:B34" & ws.UsedRange.Rows.CountLarge).Find(Value, LookAt:=xlWhole)
If Not Finder Is Nothing Then
    FirstAddress = Finder.Address
    Do
        Finder.Font.Color = RGB(0, 176, 80)
        Set Finder = Finder.FindNext(Finder)
    Loop While Not Finder Is Nothing And Finder.Address <> FirstAddress
End If
End Sub
Sub ClearColors()
For Each w In ThisWorkbook.Worksheets
    w.Range("B4:B34" & w.UsedRange.Rows.CountLarge).Interior.ColorIndex = xlNone
Next w
End Sub

Sub ChangeBackToBlack()
'ORIGINAL CODE FROM: https://www.mrexcel.com/board/threads/using-vba-to-search-over-multiple-sheets.333974/
'I modified the original code quite a bit.
Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
With ws
If ws.Name = "Sheet1" Then GoTo myNext
    With ws.Range("B4:B34").Font
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
    End With
myNext:
End With

Next ws
End Sub

 

[GWteB]

@just_bri Whenever you're interested in similar code that runs a little faster ...

Sub Color_Duplicates()

    Dim oWs     As Worksheet
    Dim oShDup  As Worksheet
    Dim rRng    As Range
    Dim c       As Range
    Dim x       As Range
    Dim sStart  As String

    Application.ScreenUpdating = False

    Set oWs = ThisWorkbook.Worksheets("Sheet1") ' << for comparison and to be excluded for any color change
    Set rRng = oWs.Range("B4:B34")

    For Each c In rRng
        If Len(c.Value) > 0 Then
            For Each oShDup In ThisWorkbook.Worksheets
                If oShDup.Name <> oWs.Name Then
                    Set x = oShDup.UsedRange.Find(c, LookAt:=xlWhole)
                    If Not x Is Nothing Then
                        sStart = c.Address
                        Do
                            x.Font.Color = RGB(0, 176, 80)
                            Set x = oShDup.UsedRange.FindNext(x)
                            If x Is Nothing Then Exit Do
                        Loop While sStart <> c.Address
                        Set x = Nothing
                    End If
                End If
            Next oShDup
        End If
    Next c

    Set rRng = Nothing
    Set oWs = Nothing
    Application.ScreenUpdating = True
End Sub

 

[just_bri]

Faster is always better. Thank you; I appreciate it!

 

[GWteB]

My pleasure!