Function ColoringWordsByList(RangeToColoring As Range, TegName$, ListRange, Optional ColorExampleCell As Range) As Long
Dim dic As Object, i&, ii&, n&, t&, tt&, RangeToColoringARR, ListRangeArr, b As Boolean
Dim columnTeg&, columnText&, tRangeToColoring As Range
Application.Volatile
If ColorExampleCell Is Nothing Then ColorN = -16776961 Else ColorN = ColorExampleCell.Font.Color
If TypeName(ListRange) = "Range" Then ListRangeArr = ListRange.Value
If TypeName(ListRangeArr) = "String" Then ReDim ListRangeArr(1 To 1, 1 To 1): ListRangeArr(1, 1) = ListRange.Value
RangeToColoringARR = RangeToColoring.Value
For i = 1 To UBound(RangeToColoringARR)
    For ii = 1 To UBound(RangeToColoringARR, 2)
            If b Then
                For t = 1 To UBound(ListRangeArr)
                     For tt = 1 To UBound(ListRangeArr, 2)
                     If Len(ListRangeArr(t, tt)) Then n = InStr(1, RangeToColoringARR(i, ii), ListRangeArr(t, tt)) Else n = 0
                        Do While n > 0
                            Set tRangeToColoring = RangeToColoring(i, ii)
                            tRangeToColoring.Characters(Start:=n, Length:=Len(ListRangeArr(t, tt))).Font.Color = ColorN
                            n = InStr(n + 1, RangeToColoringARR(i, ii), ListRangeArr(t, tt))
                            ColoringWordsByList = ColoringWordsByList + 1
                        Loop
                     Next
                Next
                b = InStr(1, RangeToColoringARR(i, ii), "(-" & TegName & ")") = 0
            Else
            b = InStr(1, RangeToColoringARR(i, ii), "(" & TegName & ")") > 0
            End If
    Next
Next
End Function