首页 >excel操作 > 内容

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

2023年4月10日 05:00

from:https://blog.csdn.net/winnyrain/article/details/9630777
原来的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 With  End Sub

这段代码有点小瑕疵,就是运行的时候,不能一次运行循环完整个文档,必须按一下“运行”完成一个,要不停的按,哈哈,不过还行,效果也还可以,结果可能会成这样:
1、硬盘出厂后必须经过____才能使用。(格式化)
2、显示器是由____与____两部分组成的。(监视器)(显示适配卡)
有两个空以上的话,中间会有右左括号)(,这时可以使用替换功能把)(替换为、即可,可者有兴趣的话在代码里加一段替换也可以哦!


参考文章:https://blog.csdn.net/yueliang2100/article/details/104600873

郑重声明:本文版权归原作者所有,转载文章仅为传播更多信息之目的,如作者信息标记有误,请第一时候联系我们修改或删除,在此表示感谢。

特别提醒:

1、请用户自行保存原始数据,为确保安全网站使用完即被永久销毁,如何人将无法再次获取。

2、如果上次文件较大或者涉及到复杂运算的数据,可能需要一定的时间,请耐心等待一会。

3、请按照用户协议文明上网,如果发现用户存在恶意行为,包括但不限于发布不合适言论妄图

     获取用户隐私信息等行为,网站将根据掌握的情况对用户进行限制部分行为、永久封号等处罚。

4、如果文件下载失败可能是弹出窗口被浏览器拦截,点击允许弹出即可,一般在网址栏位置设置

5、欢迎将网站推荐给其他人,网站持续更新更多功能敬请期待,收藏网站高效办公不迷路。

      



登录后回复

共有0条评论