Sub checkWordConsistItalic()
Set dict = CreateObject("Scripting.Dictionary")
Dim i As Integer
Dim firstI, LastI As Integer
Dim st As String
Dim arr() As String
st = " "
i = 1
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Text = " [b-zB-Z] [A-Za-z][!, ]{1,} "
.MatchWildcards = True
.Wrap = wdFindStop
Do
.Execute
If .Found = False Then
Exit Do
Else
firstI = Selection.Range.Words(2).Font.Italic
LastI = Selection.Range.Words(3).Font.Italic
If dict.Exists(UCase(Selection.Range.Text)) = False Then
dict.Add UCase(Selection.Range.Text), CStr(firstI) + CStr(LastI) '利用字典，去掉重复的部分
ReDim Preserve arr(i) '动态导入数组中
arr(i) = UCase(Selection.Range.Text) + "," + CStr(firstI) + ";" + CStr(LastI)
i = i + 1
End If
End If
Selection.Collapse wdCollapseEnd
Loop
End With
Dim brr
Dim j
If i > 1 Then
For j = 1 To UBound(arr)
brr = Split(arr(j), ",") '对数组的每一个词组进行检测
Call findMMM(CStr(brr(0)), CStr(brr(1)))
Next
Else
'MsgBox "no find"
End If
End Sub
Sub findMMM(str As String, str1 As String)
Dim formatI
Dim arr() As Variant
formatI = Split(str1, ";")
With Selection.Find
.ClearFormatting
.Text = str
.MatchCase = False
.MatchWildcards = False
.Wrap = wdFindContinue
Do
.Execute
If Not .Found Then
Exit Do
Else
If Selection.Range.Words(2).Font.Italic <> formatI(0) Or Selection.Range.Words(3).Font.Italic <> formatI(1) Then
Selection.Range.HighlightColorIndex = wdRed
End If
End If
Selection.Collapse wdCollapseEnd
Loop
End With
End Sub