|
楼主,find_x 使之单独成段宏,确实有毛病,毛病就在于\x前面有,后面没有,不配套(成对),陷入了无限循环中,我改为:每个段落只要遇到最后一个字符(段落符,也叫回车符),就退出循环了,以后遇到这种问题,就按 Ctrl + PauseBreak 键结束程序。
另外:我建议,先确定一下,是否要:全文--删除段落首尾空格,全文--删除空行,你好好想想,要是删除这么没用的空格、空行,文章会变得更加干净。
如果有同名的宏,VBE会不执行或说有问题,注意不要有同名的宏存在。
********(下面提供的宏中,如果想删除空行,必须先执行《删除段落首尾空格》宏才可。如果想把选定区域或全文清除格式,可以执行《清除格式》宏,都变成默认的宋体小五单倍行距网格勾选样式)
Sub find_x()
ActiveDocument.Content.Find.Execute findtext:="\x、", ReplaceWith:="\x", Replace:=wdReplaceAll
ActiveDocument.Content.Find.Execute findtext:="、\x", ReplaceWith:="\x", Replace:=wdReplaceAll
'查找 \x隆庆辛未\x 字样,使之单独成段
Selection.HomeKey Unit:=wdStory
Do
Selection.Find.Execute findtext:="\x", Forward:=True, Wrap:=wdFindStop
If Selection.Find.Found = False Then Exit Do
Do
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Characters.Last.Text = vbCr Then Exit Do
If Right(Selection, 2) = "\x" Then
' Selection.Font.Color = wdColorRed '红色(不想要颜色,可删除此行语句!)
Selection.InsertParagraphBefore
Selection.InsertParagraphAfter
Selection.MoveStart Unit:=wdCharacter, Count:=1
Exit Do
End If
Loop
Selection.MoveRight Unit:=wdCharacter, Count:=1
Loop
ActiveDocument.Content.Find.Execute findtext:="^p^p^p\x", ReplaceWith:="^p\x", Replace:=wdReplaceAll
ActiveDocument.Content.Find.Execute findtext:="^p^p\x", ReplaceWith:="^p\x", Replace:=wdReplaceAll
ActiveDocument.Content.Find.Execute findtext:="\x^p^p^p", ReplaceWith:="\x^p", Replace:=wdReplaceAll
ActiveDocument.Content.Find.Execute findtext:="\x^p^p", ReplaceWith:="\x^p", Replace:=wdReplaceAll
End Sub
Sub 删除段落首尾空格()
With ActiveDocument.Content.Find
.Execute findtext:="^l", ReplaceWith:="^p", Replace:=wdReplaceAll
.Execute findtext:="^13", ReplaceWith:="^p", Replace:=wdReplaceAll
End With
Selection.WholeStory
CommandBars.FindControl(ID:=122).Execute
CommandBars.FindControl(ID:=123).Execute
End Sub
Sub 删除空行()
Dim i As Paragraph
For Each i In ActiveDocument.Paragraphs
If Len(i.Range) = 1 Then i.Range.Delete
Next
End Sub
Sub 清除格式()
Selection.WholeStory
Selection.ClearFormatting
Selection.ClearFormatting
End Sub |
|