按要求复制答案到每题

ww0000

按要求复制.rar (7.16 KB, 下载次数: 53)

2013-7-2 15:30 上传

点击文件名下载附件

能否利用宏将答案部分按题号复制到每题的括号内?
或者将每题括号内的答案复制到最后?

wx486

针对附件文档，分别提供如下代码：
Sub 把文档尾段答案逐一写入题干()
Dim reg As Object, j%
Set reg = CreateObject("vbscript.regexp")
With reg
      .Global = True
      .Pattern = "[A-Z]"
      Set matches = .Execute(ActiveDocument.Paragraphs.Last.Range)
End With
Set reg = Nothing
With CreateObject("vbscript.regexp")
      .Global = True
      .MultiLine = True
j = 0
     Do While j < matches.Count
          For Each para In ActiveDocument.Paragraphs
              .Pattern = "[（/(]\s*[）/)]"
              If .test(para.Range) = True Then
                   para.Range = .Replace(para.Range, "（" & matches.Item(j) & "）")
                   j = j + 1
              End If
          Next
      Loop
End With
End Sub

Sub 把单选题各题答案按题号提取到文档末尾()
Dim matches, i%, str$
With CreateObject("vbscript.regexp")
    .Global = True
    .MultiLine = True
    .Pattern = "[A-Z](?=\s*[/)）])"
    Set matches = .Execute(ActiveDocument.Content)
End With
For Each m In matches
    i = i + 1
    str = str & i & "、" & m & vbTab
Next
Selection.EndKey wdStory
Selection.InsertAfter Chr$(13) & str
End Sub

psystyle

把单选题各题答案按题号提取到文档末尾
测试，最后一题没有实现。

psystyle

能否用替换完成呢？

wx486

psystyle 发表于 2013-7-3 06:04
把单选题各题答案按题号提取到文档末尾
测试，最后一题没有实现。

哈哈，多谢支持。是我的错，把\s?[/)）]中的?改为*。二楼代码已改，请测试。

wx486

参考http://club.excelhome.net/thread-993054-1-1.html中sqhsqhli的代码，再给出以下代码，请测试。
Sub 把文档尾段答案逐一写入题干()
    Dim a, i As Integer
    ActiveDocument.Content.Find.Execute findtext:="^32", replacewith:="", Replace:=wdReplaceAll
    a = Split(ActiveDocument.Paragraphs.Last.Range, "、")
    'ActiveDocument.Paragraphs.Last.Range.Delete
    With ActiveDocument.Content.Find
        .Text = "[\(（][\)）]"
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            i = i + 1
            If i > UBound(a) Then
                MsgBox "题目与答案不一致，将退出"
                Exit Sub
            End If
            ActiveDocument.Range(.Parent.End - 1, .Parent.End - 1).InsertAfter Left(a(i), 1)
            .Parent.Collapse Direction:=wdCollapseEnd
        Loop
    End With
End Sub

Sub 把单选题各题答案按题号提取到文档末尾()
    Dim i%
    ActiveDocument.Content.Find.Execute findtext:="^32", replacewith:="", Replace:=wdReplaceAll
    ActiveDocument.Range.InsertAfter Chr(13) & "整理的答案是："
    With ActiveDocument.Content.Find
        .Text = "[\(（][A-Z]"
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            i = i + 1
            ActiveDocument.Range.InsertAfter i & "、" & Right(.Parent.Text, 1) & vbTab
            ActiveDocument.Range(.Parent.End - 1, .Parent.End) = ""
            .Parent.Collapse Direction:=wdCollapseEnd
        Loop
    End With
End Sub

wx486

psystyle 发表于 2013-7-3 06:05
能否用替换完成呢？

替换代码已帖到6楼。如果不用VBA，仅用替换，可能的情况是，有多少题，就要单击替换多少次，记得以前有类似的帖子，有这样的替换方法。

tangqingfu

谢谢分享，收藏学习！

ww0000

wx486 发表于 2013-7-3 09:24
参考http://club.excelhome.net/thread-993054-1-1.html中sqhsqhli的代码，再给出以下代码，请测试。
Sub  ...

测试了好象有错,请检查,谢谢! 行政处罚试题及答案.rar (8.65 KB, 下载次数: 14)

2013-7-3 10:04 上传

点击文件名下载附件

wx486

ww0000 发表于 2013-7-3 10:05
测试了好象有错,请检查,谢谢!

请将文档最后的所有答案段落变成一段。
请按附件测试
行政处罚试题及答案.rar (13.94 KB, 下载次数: 32)

2013-7-3 10:15 上传

点击文件名下载附件

另：请确保你的文档没有自相矛盾现象及不必要的错误。第50题题干没有（）。