Trouvez des doublons correspondants et de la couleur de chaque couleur différente

J'essaie de trouver des doublons dans un document et que la police de chaque match unique soit une couleur différente.

J'ai modifié le code que j'ai rencontré et que cela fonctionne pour les deux premiers matchs en double uniques, puis s'arrête. P>

J'aimerais trouver uniquement des entiers uniques à 5 chiffres qui sont des correspondances en double (

Sub ColorDuplicates()
 
    Dim xRg As Range
    Dim xTxt As String
    Dim xCIxCellndex As Long
    Dim xCol As Collection
    Dim xCell As Range
    'Dim xChar As String
    Dim xCellPre As Range
    Dim I As Long

    Set xRg = ActiveDocument.Words.Last

    xCIndex = 5
    Set xCol = New Collection

    For Each xCell In ActiveDocument.Words

        On Error Resume Next
        xCol.Add xCell, xCell.Text

        If Err.Number = 457 Then
            xCIndex = xCIndex + 1
            Set xCellPre = xCol(xCell.Text)

            If xCellPre.Font.ColorIndex = 1 Then xCellPre.Font.ColorIndex = xCIndex
                xCell.Font.ColorIndex = xCellPre.Font.ColorIndex

            End If
            On Error GoTo 0


    Next

End Sub