|
请参考以下代码： '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-7-23 20:20:40
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－Option Explicit
Sub SearchSames()
Dim I As Paragraph, oSen As Range, MySearchRange As Range
Dim MyArray() As String, aArray As Variant
With ThisDocument
'遍历段落
For Each I In .Paragraphs
'如果为空白段落则跳过
If VBA.Len(I.Range) = 1 Then GoTo GN
'定义一个查找对象为下一段落开始到文档末
Set MySearchRange = .Range(I.Range.End, .Content.End)
With MySearchRange.Find '在指定的RANGE中查找
MyArray = VBA.Split(I.Range, "，") '由逗号为分隔符(本来在句子中循环,看了楼主的例子,修改)
.ClearFormatting '清除查找格式
For Each aArray In MyArray '在"句子"中循环
'如果查找到该内容,则设置为红色
Do While .Execute(findtext:=aArray)
MySearchRange.Paragraphs(1).Range.Font.Color = wdColorRed
Loop
Next
End With
GN: Next
End With
End Sub
'----------------------
Sub GetFindPar()
Dim strFindText As String, MyFindRange As Range, MyFind() As String, aFindText As Variant
'以英文逗号","为分隔符,输入需要查找的词
strFindText = VBA.InputBox("请输入需要查找的词,请以,(英文逗号)分隔!", "Microsoft Word")
If strFindText = "" Then Exit Sub '如果没有输入则退出
Application.ScreenUpdating = False '关闭屏幕更新
MyFind = VBA.Split(strFindText, ",") '定义一个以逗号为分隔符的字符串数组
For Each aFindText In MyFind '在数组中循环
Set MyFindRange = ThisDocument.Content '定义一个RANGE对象
With MyFindRange.Find
.ClearFormatting '清除格或
.Format = True '带格式查找
.Font.Color = wdColorAutomatic '查找的文本为自动色
Do While .Execute(findtext:=aFindText) '执行查找,如果每次成功查找
MyFindRange.Paragraphs(1).Range.Font.Color = wdColorBlue '设置段落为兰色
Loop
End With
Next
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
'---------------------- 注意：你的附件中，有段落编号，实际中是否存在？另外，十个字符不是很科学的判断依据，请动行以上代码，有问题再作交流。 | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-7-11 16:32
楼主
发表于 2005-7-23 21:06
