如何让试卷中的试题和答案分开，大佬们求详解

飞驰的椒麻鸡

如何让试卷中的试题和答案分开，下面的代码是我在论坛里找的，但是运行结果不对，各位老大，帮我看看啊咋回事



Sub 试题与答案分开()
    Dim S$, mt, mh, Orng As Range, trng As Range
    Dim Arg As Range, m%, i%, j%
    Set Arg = ActiveDocument.Content
    Selection.EndKey wdStory

    Selection.InsertBreak Type:=wdPageBreak    ''插入分页符

    Selection.Text = "------------------答案------------------" & Chr(13) & Chr(13)
    Selection.Font.Size = 16
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Selection.Font.Name = "黑体"

    Selection.Collapse wdCollapseEnd ''跳到下一行行首

    With CreateObject("VBScript.Regexp")
        .Global = True: .MultiLine = True
        .Pattern = "^([一二三四]+、[^\r]+\r)(?:(?!^[一二三四]+、[^\r]+\r).)+"
        For Each mt In .Execute(Arg)
            S = mt.submatches(0)
            Selection.Text = S
            Selection.Font.Size = 12
            Selection.Font.Name = "黑体"

            Selection.Collapse wdCollapseEnd

            i = mt.FirstIndex: j = mt.Length
            Set Orng = ActiveDocument.Range(i, i + j)
            .Pattern = "^【答案】+?【解析】"
            For Each mh In .Execute(Orng)
                m = m + 1
                i = mh.FirstIndex: j = mh.Length
                Set trng = ActiveDocument.Range(Orng.Start + i, Orng.Start + i + j)
                trng.Copy
                Selection.Text = m & "."
                Selection.Collapse wdCollapseEnd
                Selection.Paste
            Next
        Next
    End With
    With ActiveDocument.Content.Find
        .Text = "【答案】*【解析】[!^13]@^13"
        .Execute
        .Replacement.Text = ""
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub

小花鹿

分开是什么意思？                                                                                                               

飞驰的椒麻鸡

小花鹿 发表于 2019-5-9 11:07
分开是什么意思？                                                                                     ...

就是题目在前面，答案和解析在试卷按题目序号后面

413191246se

请楼主备份后试用下面的宏（如果有相同的宏名，如 test，请删除一个）：

1. Sub test()
   
2.     Dim s$
   
3.     Dim r As Range
   
4.     ActiveDocument.Content.Find.Execute "[^13^11]", , , 1, , , , , , "^p", 2
   
5.     ActiveDocument.Content.InsertAfter Text:=vbCr & "【题目】"
   
6.     With Selection.Find
   
7.         .Parent.HomeKey 6
   
8.         .ClearFormatting
   
9.         .Text = "【题目】"
   
10.         .Forward = True
    
11.         .MatchWildcards = True
    
12.         Do While .Execute
    
13.             With .Parent
    
14.                 .Expand 4
    
15.                 If .Text Like "【题目】?" Then Exit Do
    
16.                 Do While Not Selection.Next(4, 1) Like "【题目】*"
    
17.                     Selection.MoveEnd 4, 1
    
18.                 Loop
    
19.                 Set r = Selection.Range
    
20.                 s = ActiveDocument.Range(Start:=Selection.Characters(5).Start, End:=Selection.Characters(7).End)
    
21.                
    
22.                 If s Like "[0-9][!0-9][!0-9]" Then
    
23.                     s = Left(s, 1)
    
24.                 ElseIf s Like "[0-9][0-9][!0-9]" Then
    
25.                     s = Left(s, 2)
    
26.                 End If
    
27.                
    
28.                 Do
    
29.                     Selection.MoveStart 4, 1
    
30.                 Loop Until Selection.Paragraphs(1).Range Like "【答案】*"
    
31.                 Selection.Cut
    
32.                
    
33.                 Selection.EndKey 6
    
34.                 Selection.TypeParagraph
    
35.                 Selection.TypeText Text:=s & "、"
    
36.                 Selection.Paste
    
37.             End With
    
38.             r.Select
    
39.             Selection.Collapse 0
    
40.         Loop
    
41.     End With
    
42.    
    
43. '删除空行
    
44.     Dim i As Paragraph
    
45.     For Each i In ActiveDocument.Paragraphs
    
46.         If Asc(i.Range) = 13 Then i.Range.Delete
    
47.     Next
    
48.    
    
49.     Selection.Text = vbCr & "参  考  答  案" & vbCr & vbCr
    
50.     Selection.Style = wdStyleTitle
    
51.    
    
52.     With Selection
    
53.         With .Font
    
54.             .Kerning = 0
    
55.             .DisableCharacterSpaceGrid = True
    
56.         End With
    
57.         With .ParagraphFormat
    
58.             .AutoAdjustRightIndent = False
    
59.             .DisableLineHeightGrid = True
    
60.         End With
    
61.     End With
    
62.    
    
63.     Selection.HomeKey 6
    
64.    
    
65.     ActiveDocument.Characters(1).Copy
    
66.    
    
67. End Sub

复制代码

413191246se

楼主，下午我给你的代码我在 Word2003 下测试正常！回到家后又想了想，觉得弄复杂了，仅用强大的《查找和替换》即可实现，第二种解法如下，测试正常，请测试：

1. Sub test试卷题目与答案分开()
   
2.     Dim y$
   
3.     y = ActiveDocument.Name
   
4.     Selection.WholeStory
   
5.     Selection.Copy
   
6.     Documents.Add.Content.Paste
   
7.     Selection.EndKey 6
   
8.     Selection.TypeText Text:="【题目】"
   
9.     ActiveDocument.Content.Find.Execute "(【解析】*)(【题目】)", , , 1, , , , , , "\2", 2
   
10.     ActiveDocument.Content.Find.Execute "(【答案】*)(【题目】)", , , 1, , , , , , "\2", 2
    
11.     ActiveDocument.Paragraphs.Last.Range.Delete
    
12.     ActiveDocument.Content.InsertAfter Text:=vbCr & vbCr & "参考答案" & vbCr & vbCr
    
13.     Documents(y).Activate
    
14.     ActiveDocument.Content.Find.Execute "(【题目】)([0-9]{1,}、)(*)(【答案】)", , , 1, , , , , , "\2\4", 2
    
15.     ActiveDocument.Content.Copy
    
16.     ActiveDocument.Close savechanges:=wdDoNotSaveChanges
    
17.     Selection.EndKey 6
    
18.     Selection.Paste
    
19.     Selection.HomeKey 6
    
20.     ActiveDocument.Characters(1).Copy
    
21.     MsgBox "处理完毕！！！尚未保存！！！", 0 + 48
    
22. End Sub

复制代码

飞驰的椒麻鸡

题目和答案，解析里有图片又当如何呢

wang-way

飞驰的椒麻鸡 发表于 2019-5-11 01:00
题目和答案，解析里有图片又当如何呢

预先把所有shape转为inlineshape