ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2446|回复: 7

[求助] 求提取试题库答案,如何提取颜色为红色的答案

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-2-6 14:08 来自手机 | 显示全部楼层 |阅读模式
本帖最后由 考试加油站 于 2018-2-6 16:07 编辑

求提取答案 ,看附件,将答案提取到题后,用括号存起来
体脂管理师测考内容.rar (20.4 KB, 下载次数: 116)

TA的精华主题

TA的得分主题

发表于 2018-2-6 21:22 | 显示全部楼层
本帖最后由 duquancai 于 2018-2-6 22:04 编辑
  1. 详见楼下代码,如果与楼主的需求存在“出入”,请自行修改,不要再追问!
复制代码

TA的精华主题

TA的得分主题

发表于 2018-2-6 21:58 | 显示全部楼层
以此为准!请测试》》》》》》》》》》》》》
  1. Sub test()
  2.     Dim myStart&, myDoc As Document, b As Boolean, Q As Range, R As Range, sr$
  3.     Application.ScreenUpdating = False
  4.     Set myDoc = ActiveDocument
  5.     With myDoc.Content.Find
  6.         Do While .Execute("^13[0-9]@[.、.]", , , -1, , , 0)
  7.             With .Parent
  8.                 If Not b Then
  9.                     Set Q = myDoc.Range(.Start + 1, myDoc.Content.End)
  10.                     Set R = Q.Duplicate
  11.                     With R.Find
  12.                         .Font.ColorIndex = 6
  13.                         Do While .Execute("*", , , -1)
  14.                             If Not R.InRange(Q) Then Exit Do
  15.                             sr = sr & R.Text
  16.                         Loop
  17.                         With Q
  18.                             If sr <> "" Then
  19.                                 .End = .End - 1: .InsertAfter "(" & sr & ")": sr = Empty
  20.                             End If
  21.                         End With
  22.                     End With
  23.                     b = True
  24.                 Else
  25.                     Set Q = myDoc.Range(.Start + 1, myStart)
  26.                     Set R = Q.Duplicate
  27.                     With R.Find
  28.                         .Font.ColorIndex = 6
  29.                         Do While .Execute("*", , , -1)
  30.                             If Not R.InRange(Q) Then Exit Do
  31.                             sr = sr & R.Text
  32.                         Loop
  33.                         With Q
  34.                             If sr <> "" Then
  35.                                 .End = .End - 1: .InsertAfter "(" & sr & ")": sr = Empty
  36.                             End If
  37.                         End With
  38.                     End With
  39.                 End If
  40.                 myStart = .Start + 1: .Collapse
  41.             End With
  42.         Loop
  43.     End With
  44.     Application.ScreenUpdating = True
  45.     MsgBox "ok!"
  46. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-2-10 14:52 | 显示全部楼层
谢谢杜老师的代码,学习中。

TA的精华主题

TA的得分主题

发表于 2018-2-11 08:32 | 显示全部楼层
本帖最后由 相见是缘8 于 2018-2-13 06:03 编辑
duquancai 发表于 2018-2-6 21:58
以此为准!请测试》》》》》》》》》》》》》


大神、有不有办法让这个提取的答案变一下颜色,提取的多个答案之间加一个空格?现提取的多个答案中,答案与答案之间大挤了。

TA的精华主题

TA的得分主题

发表于 2018-2-12 21:26 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2022-1-8 08:52 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
楼主:用查找替换,什么颜色任选,如果自定义,RGB自己确定。
RGB.PNG
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 04:30 , Processed in 0.049568 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表