Option Explicit
Sub test()
Dim ar, i&, m&, n&, dic As Object, Par As Paragraph, strRngText$
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
ar = Array(35, 12272, 12273, 12274, 12275, 12276, 12277, 12278, 12279, 12280, 12281, 12282, 12283, 12286, 12287)
For i = 0 To UBound(ar): dic(ar(i)) = Empty: Next
With ActiveDocument
.Range.Font.Color = wdColorAutomatic
For Each Par In .Paragraphs
m = Len(Par.Range.Text)
strRngText = Par.Range.Text
n = 0
For i = 1 To m
If dic.Exists(AscW(Mid(strRngText, i, 1))) Then n = n + 1
Next
If n > 1 Then Par.Range.Font.Color = wdColorRed
Next
End With
Application.ScreenUpdating = True
End Sub |