试卷试题随机排序

sylun

有感于tangqingfu兄最近关于试卷题目随机排序的系列问题，感觉有一定实用性。几天来对此进行了尝试，初步编写了如下处理程序，希望对用word编辑试卷者有所帮助。作为统一回复，并为便于对类似问题的继续探讨，特另发此帖。
因对窗体的操作比较生疏，程序开头只用对话框形式对话。不知程序的适应性如何，欢迎测试，并提出修改意见。
测试文档可用tangqingfu兄的相关附件，如：
如何通过VBA生成一份内容相同但题号不同的试题 http://club.excelhome.net/viewth ... p;extra=&page=1
根据选择题A卷内容生成B卷的代码 http://club.excelhome.net/thread-384415-1-1.html
不改变题号，只改变选项内容顺序的代码 http://club.excelhome.net/thread-384424-1-2.html

使用说明
一、程序的适用
本程序主要用于对试卷各组小题及其可能存在的选项进行随机排序，也可对试卷各小题的编号进行统一排号或各组小题单独排号。
二、程序对待处理试卷排版格式的基本要求
1.大题编号格式应是罗马数字后跟点号或顿号，如“I.”，或者是汉字数字后跟顿号，如“一、”。
2.各大题中每组小题的编号格式应是阿拉伯数字后跟点号，如“1.”。
如所选区域内不同组的小题编号是相互接续的，应确保从区域内第2组起各组的第1小题的编号已临时修改为1。
3.选择题中各选项的编号格式应是英文大写字母后跟点号，如“A.”。
4.每个小题最好只有一个段落（指从每组小题的第一个编号所在段落开始算起，至该组小题的最后一题的文本区域中的每个小题。）。
5.对于选择题，如不能保证每个小题只有一个段落，起码应所选内容的最后一个小题的各选项编号前均有一个制表符。
6.小题内容请尽量避免使用表格。如有图片，请使用嵌入式。
7.如非小题编号，应避免在段落开头使用小题编号格式字样的文字内容。
三、操作说明
如运行程序前有选定内容，程序只处理选定的区域，否则对全文档进行处理。如原试卷排版格式较复杂，为避免出现排序混乱，建议分区域单独进行处理。
Option Explicit
Dim mySortRange As Range, myTempRange As Range

Sub myStarting()
'主程序
'主要针对试卷各组小题及其可能存在的选项的随机排序
Dim a As Integer, b As Integer, c As String, d As Integer
Set mySortRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
a = MsgBox("在正式开始处理前，请您先进行如下四项设定：" & vbCrLf & vbCrLf _
    & "第一项：需要对小题进行随机排序吗？", vbYesNoCancel)
If a = 2 Then Exit Sub
b = MsgBox("第二项：需要对小题中的选项进行随机排序吗？", vbYesNoCancel)
If b = 2 Then Exit Sub
c = InputBox("第三项：此项用于设置所选区域的各小题是否为连续编号。请输入大题编号的如下格式代码：" & vbCrLf & vbCrLf _
    & "　　0  各组小题均从1起独立编号，忽略编号格式" & vbCrLf & "　　1  罗马数字后跟点号或顿号，如：I." & vbCrLf _
    & "　　2  汉字数字后跟顿号，如：一、" & vbCrLf & vbCrLf & "如输入1或2将对区域内的各小题进行连续编号", , 0)
d = MsgBox("最后一项：如区域内同一大题有两组以上的小题，请确保从第2组起的各组第1小题的编号均为1。" & vbCrLf _
    & vbCrLf & "如果符合此项要求，请按确定。按取消退出程序", vbOKCancel)
If d = 2 Then Exit Sub
Application.ScreenUpdating = False
If c = "1" Or c = "2" Then FindNewGroup c
If a = 6 Then BeforeSorting
If b = 6 Then mySorting2
If c = "1" Or c = "2" Then SetSerialNumbers
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 sylun 于 2008-12-29 16:55 编辑 ]

sylun

Sub FindNewGroup(c As String)
Selection.SetRange mySortRange.Start, mySortRange.Start
With Selection.Find
    .ClearFormatting
    .MatchWildcards = True
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Wrap = wdFindStop
    Do While .Execute(IIf(c = "1", "^13[Ⅰ-Ⅻ]@[.．、]", "^13[一二三四五六七八九十]@、"))  '大题编号格式特征字符串
        If .Parent.End > mySortRange.End Then Exit Do
        .Parent.Collapse wdCollapseEnd
        If .Execute("[0-9]@[.．]") Then
            .Parent.End = .Parent.End - 1
            .Parent.Text = 1
            .Parent.Collapse wdCollapseEnd
        End If
    Loop
End With
End Sub

Sub BeforeSorting()
'用于对小题的随机排序，附属于主程序过程
Dim n As Integer, myNum As Integer
Selection.SetRange mySortRange.Start, mySortRange.Start
With Selection.Find
    .ClearFormatting
    .MatchWildcards = True
    .Text = "[0-9]@[.．]"  '小题编号格式特征字符串
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    Randomize
NF:    Do While .Execute
        With .Parent
            If .End > mySortRange.End Then Exit Do
            If .Start > 1 Then  '有限预防对小题编号文本的误判
                If .Previous(wdCharacter) Like "[!)" & Chr(9) & Chr(11) & Chr(13) & "]" Then
                    .Collapse wdCollapseEnd
                    GoTo NF
                End If
            End If
            n = n + 1
            myNum = Val(.Text)
            If n = 1 Then
                Set myTempRange = .Range
                myTempRange.StartOf wdParagraph, wdExtend
            End If
            .End = .End - 1
            .Text = Int((100 * Rnd) + 1)
            .Collapse wdCollapseEnd
            If n > 1 And myNum = 1 Then  '假设每组小题的编号均从1开始
                mySorting1
                myTempRange.Start = .Paragraphs(1).Range.Start
                .Collapse wdCollapseEnd
            Else
                myTempRange.End = .End
                myTempRange.EndOf wdParagraph, wdExtend
            End If
        End With
    Loop
    mySorting1
End With
End Sub

Sub mySorting1()
'用于对小题的随机排序，附属于BeforeSorting过程
Dim oCount As Integer
With myTempRange
    If .End < ActiveDocument.Content.End Then  '针对最后一小题的选项分属不同段落的情形，试图完整选取该小题的内容
        Do While .Next(wdCharacter) Like vbTab & "[A-H][.．]" '条件：如区域最后一个选项后跟一个制表符，则排序区域后延一个段落
            .End = .End + 1
            .EndOf wdParagraph, wdExtend
        Loop
    End If
    .End = .End - 1
    If .Characters.First Like "#" Then
        With .Find  '处理排序区域，使每小题只有一个段落
            .ClearFormatting
            .MatchWildcards = True
            .Text = "^13"
            .Execute Replacewith:="^11", Replace:=wdReplaceAll
            .Execute "^11([0-9]@[.．])", Replacewith:="^p\1", Replace:=wdReplaceAll
        End With
    End If
    .Sort FieldNumber:="段落数", SortFieldType:=wdSortFieldSyllable, Separator:=wdSortSeparateByDefaultTableSeparator
End With
With Selection
    .SetRange myTempRange.Start, myTempRange.Start
NF:    Do While .Find.Execute  '对随机排序后的小题重新编号
        If .Start > 1 Then
            If .Previous(wdCharacter) Like "[!)" & Chr(9) & Chr(11) & Chr(13) & "]" Then
                .Collapse wdCollapseEnd
                GoTo NF
            End If
        End If
        If .End > myTempRange.End Then Exit Do
        oCount = oCount + 1
        .End = .End - 1
        .Text = oCount
        .Collapse wdCollapseEnd
    Loop
End With
End Sub

sylun

Sub mySorting2()
'用于对小题中各选项的随机排序，附属于主程序过程
Dim myRange As Range, n As Byte, c As Byte
Dim myInfo() As String, Num() As Byte, i As Byte, TF As Boolean, temp As Byte
Selection.SetRange mySortRange.Start, mySortRange.Start
With Selection.Find
    .ClearFormatting
    .Replacement.Text = ""
    .MatchWildcards = True
    .Wrap = wdFindStop
    Do While .Execute("[^9^11^13]A[.．][!^9^11^13]{1,}")
        If .Parent.Start > mySortRange.End Then Exit Do
        n = n + 1
        With .Parent
            Set myRange = .Range.Duplicate
            myRange.StartOf wdParagraph, wdExtend
            .Start = .Start + 3
            ReDim Preserve myInfo(1 To n)
            myInfo(n) = .Text
            .Collapse wdCollapseEnd
            Do While .Find.Execute("[^9^11^13][A-H][.．][!^9^11^13]{1,}")  '暂设最多可8个选项
                If .Characters(2) = "A" Or .Start > mySortRange.End Then Exit Do
                n = n + 1
                .Start = .Start + 3
                ReDim Preserve myInfo(1 To n)
                myInfo(n) = .Text
                myRange.End = .Paragraphs(1).Range.End
                .Collapse wdCollapseEnd
            Loop
            If n > 1 Then
                ReDim Num(1 To n)
                Randomize
                Do While c < n  '随机排序
                    temp = Int(n * Rnd + 1)
                    For i = 1 To n
                        If Num(i) = temp Then
                            TF = True
                            Exit For
                        End If
                    Next
                    If TF = False Then
                        Num(c + 1) = temp
                        c = c + 1
                    End If
                    TF = False
                Loop
                For c = 0 To n - 1
                    If Num(c + 1) <> c + 1 Then
                        With myRange.Find
                            .Text = "(" & Chr(65 + c) & "[.．])" & myInfo(c + 1)
                            .MatchWildcards = True
                            .Replacement.Text = "\1" & myInfo(Num(c + 1))
                            .Execute Replace:=wdReplaceAll
                        End With
                    End If
                Next
                n = 0
                c = 0
                Erase myInfo, Num
                .Collapse wdCollapseStart
            End If
        End With
    Loop
End With
mySortRange.Select
End Sub
Sub SetSerialNumbers()
Dim StartNum As Integer, myCount As Integer
With Selection
    .SetRange mySortRange.Start, mySortRange.Start
    With .Find
        .ClearFormatting
        .MatchWildcards = True
        .Replacement.ClearFormatting
        .Text = "[0-9]@[.．]"
        .Replacement.Text = ""
        .Wrap = wdFindStop
        If .Execute Then StartNum = Val(.Parent.Text)
        .Parent.SetRange mySortRange.Start, mySortRange.Start
NF:        Do While .Execute
            With .Parent
                If .End > mySortRange.End Then Exit Do
                If .Start > 1 Then  '有限预防对小题编号文本的误判
                    If .Previous(wdCharacter) Like "[!)" & Chr(9) & Chr(11) & Chr(13) & "]" Then
                        .Collapse wdCollapseEnd
                        GoTo NF
                    End If
                End If
                .End = .End - 1
                .Text = StartNum + myCount
                myCount = myCount + 1
                .EndOf wdParagraph
            End With
        Loop
    End With
End With
End Sub

tangqingfu

很不错的代码,使用起来很方便,工作量大大降低!
谢谢sylun兄!
在测试时发现这种情况,在四项中,第一项选否,第二项选是,第三项选0时,第四项确定运行后，发现英文的单引号变成了中文的单引号。
发现对于自动编号的题目同样适用！
但对于像英语的完形填空并不适用！
想法：
如所选区域内不同组的小题编号是相互接续的，能否适用区域内第2组起各组的第1小题的编号不一定要从1开始？

[ 本帖最后由 tangqingfu 于 2008-12-29 21:43 编辑 ]

sylun

关于英文的单引号变成了中文的单引号问题，可能与你的自动更正选项设置有关，请看看“自动套用格式”中的“直引号替换为弯引号”是否处于选中状态。
其他问题能否举例说明？
如区域内同一大题有两组以上的小题，设定从第2组起的各组第1小题的编号须均为1（不管不同组的小题编号是否相互接续），是为了判断每组小题的结束位置，否则，如何才能判断？如果无法判断，则不同组的小题会被当作同一组处理，小题要随机排序时会出错。当然，这样的规定增加了工作量，tang兄能提供其他判断标准吗？如果所提供的判断标准又是须手工临时特别添加的，工作量同样没有减少，如不需特别添加，可能会降低程序的适应性，毕竟不同的试题设计者，其编排的格式很可能并不一样。

tangqingfu

能否添加代码以大题的题号为标准对小题题号进行处理?
下面的完形填空附件,请sylun兄测试一下,用你的代码处理,没有反应.

tangqingfu

奇怪,按sylun兄提示的,将“自动套用格式”中的“直引号替换为弯引号”前的勾去除,还是有英文的单引号变成了中文的单引号的问题,有些会变,有些又不会变,请sylun兄帮测试一下

sylun

原帖由 tangqingfu 于 2008-12-30 13:19 发表
能否添加代码以大题的题号为标准对小题题号进行处理?
下面的完形填空附件,请sylun兄测试一下,用你的代码处理,没有反应.

添加应该可以，但感觉作用不是很大。因为程序运行时起码多了一个选择，对话时还要手要输入大题号，还不如直接选定某大题再运行程序来得方便（不考虑大题多选的情形）。程序只考虑基本需要，感觉还是不要为此改动吧？
至于附件的完形填空题，因其编号排版格式与程序有所不同，故搜索不到小题编号。可查看MySorting2过程的代码，将其中"[^9^11^13]A[.．][!^9^11^13]{1,}"改为"[^9^11^13.．]A[.．][!^9^11^13]{1,}"，将"[^9^11^13][A-H][.．][!^9^11^13]{1,}"改为"[^9^11^13.．][A-H][.．][!^9^11^13]{1,}"，这样应该可搜索到，其实与使用通配符的常规查找代码字符一样，楼主可视情况自行添加上去。

奇怪,按sylun兄提示的,将“自动套用格式”中的“直引号替换为弯引号”前的勾去除,还是有英文的单引号变成了中文的单引号的问题,有些会变,有些又不会变,请sylun兄帮测试一下
刚才测试，确实还有问题，以前也遇到过（可查看http://club.excelhome.net/thread-228840-1-1.html），还没有过多考究这个问题。要修正此结果，可试将主程序改为如下代码，实际上是在最后增加了一段查找并处理的代码：

Sub myStarting3()
'主程序
'主要针对试卷各组小题及其可能存在的选项的随机排序
Dim a As Integer, b As Integer, c As String, d As Integer
Set mySortRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
a = MsgBox("在正式开始处理前，请您先进行如下四项设定：" & vbCrLf & vbCrLf _
    & "第一项：需要对小题进行随机排序吗？", vbYesNoCancel)
If a = 2 Then Exit Sub
b = MsgBox("第二项：需要对小题中的选项进行随机排序吗？", vbYesNoCancel)
If b = 2 Then Exit Sub
c = InputBox("第三项：此项用于设置所选区域的各小题是否为连续编号。请输入大题编号的如下格式代码：" & vbCrLf & vbCrLf _
    & "　　0  各组小题均从1起独立编号，忽略编号格式" & vbCrLf & "　　1  罗马数字后跟点号或顿号，如：I." & vbCrLf _
    & "　　2  汉字数字后跟顿号，如：一、" & vbCrLf & vbCrLf & "如输入1或2将对区域内的各小题进行连续编号", , 0)
d = MsgBox("最后一项：如区域内同一大题有两组以上的小题，请确保从第2组起的各组第1小题的编号均为1。" & vbCrLf _
    & vbCrLf & "如果符合此项要求，请按确定。按取消退出程序", vbOKCancel)
If d = 2 Then Exit Sub
Application.ScreenUpdating = False
If c = "1" Or c = "2" Then FindNewGroup c
If a = 6 Then BeforeSorting
If b = 6 Then mySorting2
If c = "1" Or c = "2" Then SetSerialNumbers
Selection.SetRange mySortRange.Start, mySortRange.Start
With Selection.Find
    .ClearFormatting
    .Text = "[A-Za-z]" & ChrW(8217) & "[A-Za-z]"
    .MatchWildcards = True
    .Replacement.Text = ""
    Do While .Execute
        .Parent.Range.CharacterWidth = wdWidthHalfWidth
        .Parent.SetRange .Parent.End, mySortRange.End
    Loop
End With
mySortRange.Select
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 sylun 于 2008-12-30 18:18 编辑 ]

tangqingfu

完形填空的问题解决了,谢谢sylun兄!
将主程序替换后运行后
显示:"方法与数据成员未找到"
选中的确位置位于:
mySortRange.SelectApplication.ScreenUpdating = True
的SelectApplication
请sylun兄帮忙

[ 本帖最后由 tangqingfu 于 2008-12-30 18:04 编辑 ]

sylun

原来是粘贴代码时出了点问题，两行代码合并了。已更正。
代码只对两字母间的单引号进行了处理，如其后不跟字母，则未作处理。