按要求复制答案到每题

wx486

ww0000 发表于 2013-7-3 10:56
你整理答案到文档最后是按顺序的，所以，测试文档中少了第34题后，整理出来的答案中将35题的答案放到34、 ...

你的答案部分也是没有34题答案的，题干中也没有34题，进行程序后，是正好的。没有错误

wx486

多项选择题.zip (7.68 KB, 下载次数: 36)

2013-7-3 11:08 上传

点击文件名下载附件

请看附件中多选题的处理方法。

ww0000

wx486 发表于 2013-7-3 11:08
请看附件中多选题的处理方法。

谢谢！多项选择题中，10以后的题，会将后面的数字也填入括号中！请测试！ 行政处罚试题及答案(多选题).rar (8.52 KB, 下载次数: 18)

2013-7-3 11:17 上传

点击文件名下载附件

wx486

ww0000 发表于 2013-7-3 10:56
你整理答案到文档最后是按顺序的，所以，测试文档中少了第34题后，整理出来的答案中将35题的答案放到34、 ...

可能是你的操作有问题。

ww0000

wx486 发表于 2013-7-3 11:20
可能是你的操作有问题。

没错,填答案是对的,提取答案到最后就不对了,你对一下34以后的答案!

ww0000

wx486 发表于 2013-7-3 11:08
请看附件中多选题的处理方法。

第10题以后的答案后面会多一个数字

wx486

ww0000 发表于 2013-7-3 11:27
第10题以后的答案后面会多一个数字

今天专门给你服务了。


Sub 把文档尾段答案逐一写入题干2()
    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 Mid$(a(i), 1, Len(a(i)) - 1)
            .Parent.Collapse Direction:=wdCollapseEnd
        Loop
    End With
    With ActiveDocument.Content.Find
        .Text = "([A-Z]@)([0-9]@)([\)）])"
        .Replacement.Text = "\1\3"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub




Sub 把文档尾段答案逐一写入题干()
Dim reg As Object, j%
Set reg = CreateObject("vbscript.regexp")
With reg
       .Global = True
       .Pattern = "[A-Z]+(?=[\d+\s])"
       .multiline = True
       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

wx486

ww0000 发表于 2013-7-3 11:26
没错,填答案是对的,提取答案到最后就不对了,你对一下34以后的答案!

你看看24楼的动画，难道里面的答案不对？？？？？？

ww0000

wx486 发表于 2013-7-3 11:29
今天专门给你服务了。

不错,问题解决!

再就是要请教如何将多项题的答案整理到文档最后了!!

哈哈!谢谢你专门为我服务!中午我请客!

wx486

ww0000 发表于 2013-7-3 11:44
不错,问题解决!

再就是要请教如何将多项题的答案整理到文档最后了!!

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