VBA to Highlight Duplicate Cells and Show Msg Box

I am trying to write a VBA code to highlight duplicate cells and show message box. The code I have below works but when a duplicate is entered only the first duplicate cell is highlighting in red and the message box shows. I want both cells to highlight red and show the message box. Any help on this is greatly appreciated.

Private Sub Worksheet_Change(ByVal target As Range)

Dim myRange As Range
Dim i As Integer
Dim j As Integer
Dim myCell As Range

Set myRange = Range("D1:D10")

For Each myCell In myRange
If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3
GoTo DisplayMsg

ElseIf WorksheetFunction.CountIf(myRange, myCell.Value) = 1 Or WorksheetFunction.CountIf(myRange, myCell.Value) = 0 Then
myCell.Interior.ColorIndex = 0

End If

Exit Sub

Next

DisplayMsg:
MsgBox "Duplicate URL's entered are highlighted in red"


End Sub

Thank you for the response davesexcel. Are you or someone else able to advise what the code should be for this type of situation. I have tried removing the GoTo, the Next, and moving the display message and am not able to get the result I am looking for stated above in original message.

Thank you for the help, everyone.

So removing the useless the worksheet event VBA procedure revamped :

PHP Code: 

Private Sub Worksheet_Change(ByVal Target As Range)
    With [D1:D10]
        If Intersect(.Cells, Target) Is Nothing Then Exit Sub
       .Interior.ColorIndex = xlNone
        V = Join(Filter([TRANSPOSE(IF(COUNTIF(D1:D10,D1:D10)>1,"D"&ROW(D1:D10),FALSE))], False, False), ",")
        If V > "" Then Range(V).Interior.ColorIndex = 6
    End With
End Sub 


► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

As here few range cells so slow looping is not such a concern like with this Xmas tree variation :

PHP Code: 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim C, K%, R%, Rf As Range
   With [D1:D10]
        If Intersect(.Cells, Target) Is Nothing Then Exit Sub
       .Interior.ColorIndex = xlNone
        C = Array(4, 6, 8, 24, 38)
        K = [RANDBETWEEN(0,4)]
    For R = 1 To 9
     If .Cells(R).Interior.ColorIndex = xlNone And Not IsEmpty(.Cells(R)) Then
        Set Rf = .Find(.Cells(R), .Cells(R), xlValues, 1)
         If Rf.Row > R Then
            K = (K + 1) Mod 5
           .Cells(R).Interior.ColorIndex = C(K)
         Do
            Rf.Interior.ColorIndex = C(K)
            Set Rf = .FindNext(Rf)
         Loop Until Rf.Row = R
         End If
     End If
    Next
   End With
        Set Rf = Nothing
End Sub 


► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

What if you use conditional formatting to highlight the duplicates, then use the change event to give the message.

Please Login or Register  to view this content.

Thank you Marc and ByteMarks for your responses. I have tried all three responses and am not getting exactly what I am looking for. Marc your codes removed the message box which I need. ByteMarks yes, I could use conditional formatting, but I need this built into the code. Thank you for helping out with this.

As I wrote « removing the useless » but you can add it …

Based on your original code, maybe:

Please Login or Register  to view this content.