Option Explicit

Sub ВыделитьДубликаты()

    Dim c           As Range
    Dim i As Long, m As Object

    Dim rg          As Object
    Set rg = CreateObject("VBScript.RegExp")
    rg.Pattern = "\s(\d+)\s"
    rg.Global = True

    Dim dict        As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim arr         As Variant
    arr = Selection.Value

    For i = 1 To UBound(arr, 1)

        For Each m In rg.Execute(arr(i, 1))
            dict(m.SubMatches(0)) = dict(m.SubMatches(0)) + 1
        Next

    Next

    i = 1
    
    For Each c In Selection

        For Each m In rg.Execute(arr(i, 1))
            If dict(m.SubMatches(0)) > 1 Then _
                    c.Characters(m.FirstIndex + 2, Len(m.SubMatches(0))).Font.Color = vbRed
        Next

        i = i + 1
    Next

End Sub