Поиск по ключевым словам

Sub ПокраскаНомеров()
Dim sFindText, sSaver, sPrepare As String
Dim iCounter, iLowBound As Integer
Dim iNumber As Variant
Dim aDbl_Array As Variant
Selection.HomeKey Unit:=wdStory
ReDim aDbl_Array(1, 0)
sFindText = "[0-9]-[0-9]{3}-[0-9]{3}-[0-9]{2}-[0-9]{2}"
'"[0-9][-][0-9]{3}[-][0-9]{3}[-][0-9]{2}[-][0-9]{2}"
iCounter = 0
    With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = sFindText
    Do While .Execute = True
        sSaver = Selection.Text
        If aDbl_Array(0, 0) = Empty Then
            aDbl_Array(0, 0) = sSaver: aDbl_Array(1, 0) = 1
        Else
            iNumber = CheckIt(aDbl_Array, sSaver)
'iNumber = натуральное число - в Массиве есть такой элемент, iNumber = 999999 - нету
            If iNumber = 999999 Then
                iLowBound = UBound(aDbl_Array, 2) + 1
                ReDim Preserve aDbl_Array(1, iLowBound)
                aDbl_Array(0, iLowBound) = sSaver: aDbl_Array(1, iLowBound) = 1
            Else
                iCounter = aDbl_Array(1, iNumber): iCounter = iCounter + 1
                aDbl_Array(1, iNumber) = iCounter
            End If
        End If
    Loop
    End With
sPrepare = Упрощение(aDbl_Array)
Call МаркировкаНомеров(sPrepare)
End Sub
Private Function CheckIt(ByVal aDbl_Array As Variant, ByVal sSaver As String) As Variant
Dim i As Integer
    For i = LBound(aDbl_Array, 2) To UBound(aDbl_Array, 2)
        If sSaver Like aDbl_Array(0, i) Then: CheckIt = i: Exit Function
    Next i
CheckIt = 999999
End Function
Private Function Упрощение(ByVal aDbl_Array As Variant)
Dim i, iTopBound As Integer
Dim aNumberArray As Variant
ReDim aNumberArray(0)
For i = LBound(aDbl_Array, 2) To UBound(aDbl_Array, 2)
    If aDbl_Array(1, i) > 3 Then
        If Not aNumberArray(0) = Empty Then
            iTopBound = UBound(aNumberArray) + 1
            ReDim Preserve aNumberArray(iTopBound)
            aNumberArray(iTopBound) = aDbl_Array(0, i)
        End If
        If aNumberArray(0) = Empty Then aNumberArray(0) = aDbl_Array(0, i)
    End If
Next i
    Упрощение = Join(aNumberArray, ", ")
End Function
Private Sub МаркировкаНомеров(ByVal sPrepare As String)
Dim i
Options.DefaultHighlightColorIndex = wdYellow
    sMass = Replace(sPrepare, Chr(32), "")
    aMyArray = Split(sPrepare, ",")
For i = LBound(aMyArray) To UBound(aMyArray)
iFirst = 0
Selection.HomeKey Unit:=wdStory
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = False
    .Text = aMyArray(i)
    Do While .Execute = True
        If ActiveDocument.Range(1, Selection.End).Characters.Count = iFirst Then GoTo NextKey
            'HighLightColorIndex можно выбрать на своё усмотрение
        If iFirst = 0 Then iFirst = ActiveDocument.Range(1, Selection.End).Characters.Count
        If Selection.Range.HighlightColorIndex = 0 Then: Selection.Range.HighlightColorIndex = wdYellow
    Loop
End With
NextKey:
    iFirst = 0
Next i
Selection.HomeKey Unit:=wdStory
End Sub