将题后的答案转变成每小题对应尾注的代码

thunor

一套试卷，题后有每小题答案，目前想将题后的答案转为每小题对应的尾注，请问谁有代码吗？谢谢。
如果有现成的，就想偷个懒，求个现成的。

thunor

本想等个想在现成的，没想到使用的人少，我就自己将它解决了。以下代码要求必须是答案位于试卷的最后（不是题后，这个另有代码），答案开始部位必须以“{【参考答案】}”标记。由于时间匆忙，请大家指正。
Sub AfterKeytoEndNote()
                 With ActiveDocument.Content.Find '将软回车替换为硬回车
                    .ClearFormatting
                    With .Replacement
                        .ClearFormatting
                    End With
                    .Execute FindText:="^l", ReplaceWith:="^p", Format:=True, Replace:=wdReplaceAll
                End With
                With ActiveDocument.Content.Find        '去掉一个空格，该空格的前面不为空格或英文字符，该空格后不为空格且不包含在域中
                    .ClearFormatting
                    .Font.Underline = WdUnderline.wdUnderlineNone
                    .MatchWildcards = True
                    With .Replacement
                        .ClearFormatting
                    End With
                    .Execute FindText:="([!^32　a-zA-Z])([　 ]{1})([!^32　][!eq])", ReplaceWith:="\1\3", Format:=True, Replace:=wdReplaceAll
                End With
                With ActiveDocument.Content.Find '规范小数的正确写法
                    .ClearFormatting
                    .MatchWildcards = True
                    With .Replacement
                        .ClearFormatting
                    End With
                    .Execute FindText:="([0-9]{1,2})([.、])([（\(【一-龥])", ReplaceWith:="\1．\3", Format:=True, Replace:=wdReplaceAll
                End With
                With ActiveDocument.Content.Find '规范小数的正确写法
                    .ClearFormatting
                    .MatchWildcards = True
                    With .Replacement
                        .ClearFormatting
                    End With
                    .Execute FindText:="([^13])([0-9]{1,2})([,，.、·])([!0-9])", ReplaceWith:="\1\2．\4", Format:=True, Replace:=wdReplaceAll
                End With
                With ActiveDocument.Content.Find '规范小数的正确写法
                    .ClearFormatting
                    .MatchWildcards = True
                    With .Replacement
                        .ClearFormatting
                    End With
                    .Execute FindText:="([0-9])(．)([0-9])", ReplaceWith:="\1.\3", Format:=True, Replace:=wdReplaceAll
                End With
                With ActiveDocument.Content.Find '规范小数的正确写法
                    .ClearFormatting
                    .MatchWildcards = True
                    With .Replacement
                        .ClearFormatting
                    End With
                    .Execute FindText:="([0-9])([.])([0-9]{4}[年])", ReplaceWith:="\1．\3", Format:=True, Replace:=wdReplaceAll
                End With
                With ActiveDocument.Content.Find '将连续回车替换为一个回车
                    .ClearFormatting
                    With .Replacement
                        .ClearFormatting
                    End With
                    .Execute FindText:="^p^p", ReplaceWith:="^p", Format:=True, Replace:=wdReplaceAll
                End With
                Dim KeyParagraphs As Integer
                ActiveDocument.ActiveWindow.Selection.HomeKey Unit:=wdStory
                With ActiveDocument.ActiveWindow.Selection.Find
                    .ClearFormatting
                    .Text = "{【参考答案】}"
                    .Forward = True
                    .Execute
                    If .Found = False Then
                        MsgBox "没有找到关键字" & """" & "{【参考答案】}" & """" & "的位置，请标注。", MsgBoxStyle.Information, "注意："
                        Exit Sub
                    End If
                End With
                KeyParagraphs = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count
                Dim m As Integer
                Dim n As Integer
                Dim i As Integer
                Dim c As Integer
                Dim ktStartp As Integer
                Dim keyStartp As Integer
                Dim nextkeyStartp As Integer
                Dim ktNo As Integer
                Dim KeyTxt As String
                Dim keyStartRange As Range
                Dim myParagraphs As Integer
                Dim str As String
                nextkeyStartp = KeyParagraphs
                Dim TotalKT As Integer
                For i = 1 To ActiveDocument.Range.Paragraphs.Count
                    str = ActiveDocument.Range.Paragraphs(i).Range.Text
                    If isTrue(str, 1) > 0 And Val(str) > ktNo Then
                        ktNo = CInt(Val(str))
                        TotalKT = TotalKT + 1
                    End If
                Next
                ktNo = 0
                MsgBox "共能找到答案" & TotalKT & "个。", vbInformation, "注意："
               
                If ActiveDocument.Endnotes.Count > 0 Then
               
                    If MsgBox("已有尾注" & ActiveDocument.Endnotes.Count & "个,需要全删除才能进行后续过程，删吗？", vbYesNo, "注意：") = vbNo Then
                        Exit Sub
                    End If
                    For m = 1 To ActiveDocument.Endnotes.Count
                        ActiveDocument.Endnotes.Item(1).Delete
                    Next
                End If
                Application.ScreenUpdating = True
                For n = nextkeyStartp + 1 To ActiveDocument.Paragraphs.Count
                    If ActiveWindow.Selection.Tables.Count > 0 Then Exit For
                    ActiveDocument.Paragraphs(n).Range.Select
                    str = ActiveDocument.ActiveWindow.Selection.Text
                    If isTrue(str, 1) > 0 And Val(str) > ktNo Then
                        ktNo = CInt(Val(str))
                        keyStartp = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count
                        ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
                        ActiveWindow.Selection.MoveLeft Unit:=wdCharacter, Count:=1
                        If ktNo = TotalKT Then
                          Set keyStartRange = ActiveDocument.Range(ActiveDocument.Paragraphs(keyStartp).Range.Start, ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.End)
                            GoTo 341
                        End If
                        For c = keyStartp + 1 To ActiveDocument.Paragraphs.Count
                            ActiveDocument.Paragraphs(c).Range.Select
                            str = ActiveDocument.ActiveWindow.Selection.Text
                            If isTrue(str, 1) > 1 And Val(str) > ktNo Then
                                nextkeyStartp = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count
                                Application.ScreenUpdating = True
                                Exit For
                            End If
                            If c = ActiveDocument.Paragraphs.Count Then
                                nextkeyStartp = ActiveDocument.Paragraphs.Count
                            End If
                        Next
                       Set keyStartRange = ActiveDocument.Range(ActiveDocument.Paragraphs(keyStartp).Range.Start, ActiveDocument.Paragraphs(nextkeyStartp - 1).Range.End)
341:
                        keyStartRange.Select
                        KeyTxt = ActiveWindow.Selection.Text
                        
                        ActiveDocument.ActiveWindow.Selection.HomeKey Unit:=wdStory
                        With ActiveDocument.ActiveWindow.Selection.Find
                            .ClearFormatting
                            .Text = "^p" & ktNo & "．"
                            .Forward = True
                            .Execute
                            If .Found = True Then
                                ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
                                If ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count < keyStartp Then
                                    ActiveDocument.Endnotes.Add ActiveWindow.Selection.Range, Text:=KeyTxt
                                End If
                            End If
                        End With
                    End If
                Next
                ActiveDocument.ActiveWindow.Selection.HomeKey Unit:=wdStory
                ActiveDocument.Endnotes.NumberStyle = WdNoteNumberStyle.wdNoteNumberStyleArabic
                Application.ScreenUpdating = True

End Sub
Public Function isTrue(ByVal sText As String, ByVal SelItem As Integer) As Integer
isTrue = 0
Dim reg
Set reg = CreateObject("vbscript.regexp")
Select Case SelItem
Case 1
    With reg
        .Global = True
        .IgnoreCase = True
        .Pattern = "\d{1,2}[．]"
        If .test(sText) Then
           isTrue = 1
        End If
    End With
Case 2
    With reg
        .Global = True
        .IgnoreCase = True
        .Pattern = "(^[【])([答])([案])([】])"
        If .test(sText) Then
           isTrue = 1
        End If
    End With
End Select
End Function

w2001pf6604

尾注是什么啊?怎么不是答案放在每道试题的后面?即题目+答案的形式

thunor

尾注有尾注的方便，题后有题后的方便，看你怎么使用。尾注在制卷时对排版影响相对较小。而且光标指在尾注编号处，答案文字也出来了。

过客fppt

thunor 发表于 2024-8-18 13:15
尾注有尾注的方便，题后有题后的方便，看你怎么使用。尾注在制卷时对排版影响相对较小。而且光标指在尾注编 ...

是为了打印的时候不显示答案，批改的时候用电脑对着答案批改吗

thunor

过客fppt 发表于 2024-8-18 22:00
是为了打印的时候不显示答案，批改的时候用电脑对着答案批改吗

这个看你怎么使用了，我个人认为排版时用它真的很方便。基本上所见即所得。

过客fppt

thunor 发表于 2024-8-19 15:55
这个看你怎么使用了，我个人认为排版时用它真的很方便。基本上所见即所得。

试题排序我都是直接用插件的，导航窗格中看得见

thunor

我一般是用自己的题库生成试题（有三万多道题） ，A4排好版，输出。然后利用自己的窗格助手进行一系列的处理， 比如生成页码、制卷好后学生卷删除尾注等。

过客fppt

thunor 发表于 2024-8-19 22:55
我一般是用自己的题库生成试题（有三万多道题），A4排好版，输出。然后利用自己的窗格助手进行一系列的处理 ...

如果要删除答案，在每一道题目后面添加上题目结束的标志，用通配符可以全部删掉啊，当然添加题目结束标志也可以用vba

另外那么大规模的试题组卷，你们不用学科网或菁优网的吗，这样还可以及时的搜到很多新的题目

thunor

用学科网，但是一些题具有基础性、代表性，选择下来后来需要时使用也很方便。每年全省各地、市的题也录入题库中，需要的话来年也可使用，而且导入题库也很方便。学科网、菁优网相对而言本省题较少，跟不上进度，不入多个本学科群上传的题丰富。