使用WORD宏实现查找带格式的文字并复制到特定地方

原来的WORD文档内容是这样的：

1、硬盘出厂后必须经过格式化才能使用。

2、显示器是由监视器与显示适配卡两部分组成的。

.......

内容类似于带考试试卷上答案的填空题。目前的需求是把答案部分留空，并设置下画线，然后把答案列到后面以括号括起来，最终结果为这样：

1、硬盘出厂后必须经过____才能使用。(格式化)

2、显示器是由____与____两部分组成的。(监视器、显示适配卡)

.......

但是整篇WORD文档这样的有数百题之多，手工改固然非常麻烦费时，所以用宏来解决吧，虽然对WORD的宏不太熟，但是参考了一些文档后，基本满足要求，代码见下：

Sub CopyAnswer()With ActiveDocument.Content.Find.ClearFormatting.Font.Underline = wdUnderlineSingle '查找下划线格式.Execute Format:=True, Forward:=True '执行查找    If .Found = True Then ' 如果已找到带下划线格式的             .Parent.Font.Underline = wdNone '去掉下划线            If InStr(1, .Parent.Text, vbCr) > 0 Then '判断是否段落结尾                With .Parent                    .SetRange .Start + 0, .End - 1 '如果是段落结尾，把选择范围向左缩小一个字符，以免把回车符也选择了                    .Select '执行选择            End With    End If    .Parent.Select '为保险再执行一次选择        .Parent.Copy '复制选择的内容              If InStr(1, .Parent.Text, "。") > 0 Then '是否有。号结尾        .Parent.Text = "____。" '有的话人才能复制的内容也补充。号    Else        .Parent.Text = "____" '没有的话以____代替原来下划线的内容    End If             .Application.Selection.MoveDown Unit:=wdParagraph '移动光标到下一段落     .Application.Selection.MoveLeft Unit:=wdCharacter, Count:=1 '光标往左移一格，目的是把光标移到复制文本这段的末尾             '加入左括号    .Application.Selection.Text = "("    .Application.Selection.MoveRight Unit:=wdCharacter, Count:=1 '避免加完括号后被选择         .Application.Selection.Paste '贴粘复制的内容    '加入右括号    .Application.Selection.Text = ")"    End IfEnd WithEnd Sub

这段代码有点小瑕疵，就是运行的时候，不能一次运行循环完整个文档，必须按一下“运行”完成一个，要不停的按，哈哈，不过还行，效果也还可以，结果可能会成这样：

1、硬盘出厂后必须经过____才能使用。(格式化)

2、显示器是由____与____两部分组成的。(监视器)(显示适配卡)

有两个空以上的话，中间会有右左括号)(，这时可以使用替换功能把)(替换为、即可，可者有兴趣的话在代码里加一段替换也可以哦！