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

chuhaiou

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

tangqingfu

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

chuhaiou

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

sylun

原帖由 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

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

sylun

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

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

chuhaiou

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

tangqingfu

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

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

sylun

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

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

sylun

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

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