如何通过VBA提取指定颜色的文字及其题号?

chuhaiou · 发表于 2009-5-23 19:05

我还是想将选择题合并成一个段落,这样才完美!谢谢sylun兄的指教,同时谢谢tangqingfu兄提出了这么实用的话题!

tangqingfu · 发表于 2009-5-23 19:11

chuhaiou兄是想将选择题答案合并成一个段落,还是一行?
如果是一行,当选择题很多时,一行就放不下了；如果是一段,可以选中选择题答案部分,用替换法可以轻松解决
查找内容:
^p
替换为^32

chuhaiou · 发表于 2009-5-23 19:23

我主要想一键搞定!<<化学金排>>有这个功能但运行速度不是太快!

sylun · 发表于 2009-5-23 23:24

原帖由 chuhaiou 于 2009-5-23 19:05 发表
我还是想将选择题合并成一个段落...

可试试如下代码。只是要说明一点：如用红色直接标注选项，请只标注字母本身，不要连后面的标点也标注，可以标注多个选项，也可以括号内标注。另外，不保证可准确判断选择题的结束位置，如其后一题答案内容是以A-F开头，则选择题答案可能与其后一题答案内容在同一段落。
Sub test5()
'没有选定内容则对全文档进行处理
Dim oDoc As Document, Doc As Document
Dim myRange As Range
Dim num%, i%, info$, num2%, myend&
On Error Resume Next
Application.ScreenUpdating = False
Set oDoc = ActiveDocument
Set Doc = Documents.Add
oDoc.Activate
Set myRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
myRange.Select
With Selection.Find
.ClearFormatting
.Text = ""
.Font.Color = wdColorRed  '答案内容以红色字体标注
.Format = True
.Replacement.ClearFormatting
Do While .Execute
      If .Parent.End > myRange.End Then Exit Do
      num = Int(Val(.Parent.Paragraphs(1).Range.Text))
      Do While num = 0
         i = i + 1
         num = Int(Val(.Parent.Previous(wdParagraph, i).Text))
         If i > 10 Then Exit Do
      Loop
      If .Parent.Paragraphs(1).Range.End = myend Then
         Doc.Content.InsertAfter "　　"
      Else
         Doc.Content.InsertAfter vbCrLf & IIf(num = num2, "", num & "．")
      End If
      Doc.Bookmarks("\endofdoc").Range.FormattedText = .Parent.FormattedText
      myend = .Parent.Paragraphs(1).Range.End
      num2 = num
      i = 0
      If .Parent.End = myRange.End Then Exit Do
Loop
End With
With Doc.Content
.Characters.First.Delete
With .Find
      .MatchWildcards = True
      .Execute "^13　　", replacewith:="^p", Replace:=wdReplaceAll
      Do While .Execute("([．　])([A-FＡ-Ｆ]@)[^13　]", replacewith:="\1\2　", Replace:=wdReplaceOne)
         .Parent.Collapse wdCollapseEnd
      Loop
      .Parent.WholeStory
      Do While .Execute("([．　][A-FＡ-Ｆ]@)　　([A-FＡ-Ｆ][^13　])", replacewith:="\1\2", Replace:=wdReplaceOne)
         .Parent.Collapse wdCollapseEnd
      Loop
      .Parent.WholeStory
      .Execute "　^13", replacewith:="^p", Replace:=wdReplaceAll
      .Execute "([．　][A-FＡ-Ｆ]@)　([0-9]@．[!A-FＡ-Ｆ])", replacewith:="\1^p\2", Replace:=wdReplaceAll
      .Execute "^13{2,}", replacewith:="^p", Replace:=wdReplaceAll
      .Font.Color = wdColorRed
      With .Replacement.Font
         .Color = wdColorAutomatic
         .Underline = wdUnderlineNone
         .Bold = False
         .Italic = False
      End With
      .Execute "", Format:=True, MatchWildcards:=False, replacewith:="^&", Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub，

[ 本帖最后由 sylun 于 2009-5-23 23:40 编辑 ]

chuhaiou · 发表于 2009-5-23 23:47

sylun兄的est5还有点问题.我发来附件请你帮忙,谢了!

sylun · 发表于 2009-5-24 00:28

原帖由 chuhaiou 于 2009-5-23 23:47 发表
sylun兄的est5还有点问题.我发来附件请你帮忙,谢了!

问题主要出在您的标注不够规范。可以用常规方法查看一下文档中红色字体的分布情况，是不是有多余的空格。当然，估计有办法有限避免此问题。
另外，当答案为三个选项以上时，生成的文本会出现多余的空格，问题出在第二个.Parent.Collapse wdCollapseEnd语句行，应将参数wdCollapseEnd改为wdCollapseStart

chuhaiou · 发表于 2009-5-24 07:29

只能实现选择题第2,3题同一段落,其它选择题还是一题一个段落.

tangqingfu · 发表于 2009-5-24 09:29

请教sylun兄：
代码能做到选择题是多项选择题时,选项答案ABCD等是连在一起的，不论用户有没有选择到先期ABCD后面的点.或．或、（或后面的空格），均只提取ABCD部分，不提取后面的点和空格；如果选项是（A）或(A)这样的形式，也只提取A这样的形式，选择题的答案能以5、10、15或20小题为一行？各小题均分该行的宽度？

[ 本帖最后由 tangqingfu 于 2009-5-24 09:40 编辑 ]

sylun · 发表于 2009-5-24 10:05

原帖由 chuhaiou 于 2009-5-24 07:29 发表
只能实现选择题第2,3题同一段落,其它选择题还是一题一个段落.

看来您这次还是没有认真看看我的相关回复。

sylun · 发表于 2009-5-24 10:28

原帖由 tangqingfu 于 2009-5-24 09:29 发表
请教sylun兄：
代码能做到选择题是多项选择题时,选项答案ABCD等是连在一起的，不论用户有没有选择到先期ABCD后面的点.或．或、（或后面的空格），均只提取ABCD部分，不提取后面的点和空格；如果选项是（A）或(A)这样 ...

我觉得程序本身的功能总是有限的，不可能面面俱到，能解决基本问题或主要问题就行了。我想需要用到这样的程序的人，都是经常操作word的，所以，对标注操作规范一下都难以保证，这好像说不过去，这可能是态度问题。
程序本身并不清楚哪些内容属于选择题，只是根据文本特征来作想当然的特别处理，因此，不能保证没有误判或漏判。如果特征太复杂，这样的判断就更不好把握，误判的可能性增大。我可以尝试处理一下其中的一些“或”，但这是很费时的活，得好好想想。至于（A）或(A)及均分宽度的问题我就不考虑了。

		自动登录	找回密码
密码			免费注册

[求助] 如何通过VBA提取指定颜色的文字及其题号?