如何在word格式题库中随机抽取部分题目形成试卷

401rani · 发表于 2008-11-26 12:02

各位老师，我现在正在为学校整理题库，希望每次在word格式的文档中随机抽取30道题形成新的试卷，不知能否实现，多谢啊。附件为包含40道题的题库，实际题库有300道，有文字和图片，希望每次抽取30道题。

试题集.rar (83.84 KB, 下载次数: 1232)

sylun · 发表于 2008-11-26 21:49

试试如下程序：
Sub test()
'假设题号编号格式均与附件相同。注：题库中每题之间须有一空行相隔，且每题的内容中不能有空行。
Dim a As String, c As Integer
Dim n As Integer, temp As Integer, TF As Boolean, Num() As Integer, i As Integer, j As Integer
Dim myInfo As String, myDoc As Document, Doc As Document, myRange As Range, tempRange As Range
a = InputBox("请输入需提取的总题数", , "30")
Application.ScreenUpdating = False
Set myDoc = ActiveDocument
With myDoc.Content.Find
.ClearFormatting
.Text = "^13[（(][ABCD]@[）)][0-9]@、"
.MatchWildcards = True
Do While .Execute  '统计题库文档（活动文档）的总题数
      c = c + 1
      .Parent.SetRange .Parent.End, ActiveDocument.Content.End
Loop
If CInt(a) > c Or CInt(a) <= 0 Then Exit Sub  '输入数据不在总题数范围内则退出程序
Randomize
Do While n < CInt(a)  '随机选取不重复题号
      ReDim Preserve Num(n)
      temp = Int((c * Rnd) + 1)
      If n > 0 Then
         For i = 0 To UBound(Num)
            If Num(i) = temp Then
                  TF = True
                  Exit For
            End If
         Next
      End If
      If TF = False Then
         Num(n) = temp
         n = n + 1
      End If
      TF = False
Loop
For i = 0 To CInt(a) - 2  '排序
      For j = i + 1 To CInt(a) - 1
         If Num(i) > Num(j) Then
            temp = Num(i)
            Num(i) = Num(j)
            Num(j) = temp
         End If
      Next
Next
myInfo = "提取记录" & vbCrLf & "题号" & vbTab & "题库题号" & vbCrLf
For i = 0 To CInt(a) - 1  '取得试题题号与题库题号的对应数据
      myInfo = myInfo & i + 1 & vbTab & Num(i) & Chr(13)
Next
Set Doc = Documents.Add
For i = 0 To CInt(a) - 1  '以新文档按顺序输出提取结果
      .Parent.WholeStory
      .Text = "^13[（(][ABCD]@[）)]" & Num(i) & "、"
      If .Execute Then
         Set myRange = .Parent
         With myRange
            .Select
            Selection.Collapse wdCollapseStart
            If Selection.Find.Execute("^13^13") Then
                  .SetRange .Start + 1, Selection.End
            Else
                  .SetRange .Start + 1, myDoc.Content.End
            End If
         End With
         Set tempRange = Doc.Bookmarks("\EndofDoc").Range
         tempRange.FormattedText = myRange.FormattedText
         tempRange.Find.Execute "([（(][ABCD]@[）)])" & Num(i) & "(、)", _
            MatchWildcards:=True, replacewith:="\1" & i + 1 & "\2", Replace:=wdReplaceOne
      End If
Next
End With
Doc.Content.InsertAfter vbCrLf & myInfo  '在新文档结尾插入对照记录
Doc.Activate
Application.ScreenUpdating = True
MsgBox "提取结果及题号对照记录见新文档。"
End Sub

401rani · 发表于 2008-12-3 11:43

太感谢了，解决大问题了。

sakyu · 发表于 2010-6-22 20:51

楼主您好，看到你提供的程序我非常高兴，因为我也是一名教师，经常要给学生出题考试。您的程序可以极大的提高我的工作效率。就试着修改了一下你提供的程序在的我的题库上运行了一下，郁闷的是没有结果出来。您能不能帮我看看，将程序修改一下，使它能够利用我的题库出题。谢谢！

[ 本帖最后由 sakyu 于 2010-6-22 20:53 编辑 ]

tangqingfu · 发表于 2010-6-22 21:46

谢谢sylun兄的分享，学习ing……
如果各小题前均为无答案时，代码该如何编写？

[ 本帖最后由 tangqingfu 于 2010-6-22 22:07 编辑 ]

sylun · 发表于 2010-6-23 15:34

原帖由 sakyu 于 2010-6-22 20:51 发表
楼主您好，看到你提供的程序我非常高兴，因为我也是一名教师，经常要给学生出题考试。您的程序可以极大的提高我的工作效率。就试着修改了一下你提供的程序在的我的题库上运行了一下，郁闷的是没有结果出来。您能不能 ...

对比一下每题排版格式开头的字符特征，可看出新附件有两点不同，一是选项字母用小写，二是当中使用了几个空格。
因此，可将2楼程序中涉及查找替换的几行代码作如下修改：
1.　将.Text = "^13[（(][ABCD]@[）)][0-9]@、"修改为
　　.Text = "^13[\[（(][abcd^32]@[\]）)][0-9^32]@、"
2.　将.Text = "^13[（(][ABCD]@[）)]" & Num(i) & "、"修改为
　　.Text = "^13[\[（(][abcd^32]@[\]）)][" & Num(i) & "^32]@、"
3.　将tempRange.Find.Execute "([（(][ABCD]@[）)])" & Num(i) & "(、)", _
MatchWildcards:=True, replacewith:="\1" & i + 1 & "\2", Replace:=wdReplaceOne修改为
　　tempRange.Find.Execute "([\[（(][abcd^32]@[\]）)])[" & Num(i) & "^32]@(、)", _
MatchWildcards:=True, replacewith:="\1 " & i + 1 & "\2", Replace:=wdReplaceOne

如果各小题前无答案，相应修改上面几个查找替换代码（使用通配符）就可以了。程序是以查找替换为基础的。
　　
　　

tangqingfu · 发表于 2010-6-23 16:21

谢谢sylun兄！
昨天试了修改查找2楼的代码，没能成功！
等一下再试试

tangqingfu · 发表于 2010-6-23 21:05

按sylun兄的指点操作了一遍，可以实现随机抽取了！感谢sylun兄！

tangqingfu · 发表于 2010-6-23 20:08

试修改sylun兄2楼的代码，预适合随机抽取各小题前均为无答案时的题目，但获得的只是抽取记录，而没有题目。不知问题出在哪里，要如何修改？
Sub test()
'假设题号编号格式均与附件相同。注：题库中每题之间须有一空行相隔，且每题的内容中不能有空行。
Dim a As String, c As Integer
Dim n As Integer, temp As Integer, TF As Boolean, Num() As Integer, i As Integer, j As Integer
Dim myInfo As String, myDoc As Document, Doc As Document, myRange As Range, tempRange As Range
a = InputBox("请输入需提取的总题数", , "30")
Application.ScreenUpdating = False
Set myDoc = ActiveDocument
With myDoc.Content.Find
.ClearFormatting
.Text = "^13[0-9]@、"
.MatchWildcards = True
Do While .Execute  '统计题库文档（活动文档）的总题数
      c = c + 1
      .Parent.SetRange .Parent.End, ActiveDocument.Content.End
Loop
If CInt(a) > c Or CInt(a) <= 0 Then Exit Sub  '输入数据不在总题数范围内则退出程序
Randomize
Do While n < CInt(a)  '随机选取不重复题号
      ReDim Preserve Num(n)
      temp = Int((c * Rnd) + 1)
      If n > 0 Then
         For i = 0 To UBound(Num)
            If Num(i) = temp Then
                  TF = True
                  Exit For
            End If
         Next
      End If
      If TF = False Then
         Num(n) = temp
         n = n + 1
      End If
      TF = False
Loop
For i = 0 To CInt(a) - 2  '排序
      For j = i + 1 To CInt(a) - 1
         If Num(i) > Num(j) Then
            temp = Num(i)
            Num(i) = Num(j)
            Num(j) = temp
         End If
      Next
Next
myInfo = "提取记录" & vbCrLf & "题号" & vbTab & "题库题号" & vbCrLf
For i = 0 To CInt(a) - 1  '取得试题题号与题库题号的对应数据
      myInfo = myInfo & i + 1 & vbTab & Num(i) & Chr(13)
Next
Set Doc = Documents.Add
For i = 0 To CInt(a) - 1  '以新文档按顺序输出提取结果
      .Parent.WholeStory
      .Text = "^13" & Num(i) & "、"
      If .Execute Then
         Set myRange = .Parent
         With myRange
            .Select
            Selection.Collapse wdCollapseStart
            If Selection.Find.Execute("^13^13") Then
                  .SetRange .Start + 1, Selection.End
            Else
                  .SetRange .Start + 1, myDoc.Content.End
            End If
         End With
         Set tempRange = Doc.Bookmarks("\EndofDoc").Range
         tempRange.FormattedText = myRange.FormattedText
         tempRange.Find.Execute Num(i) & "(、)", _
            MatchWildcards:=True, replacewith:=i + 1 & "\1", Replace:=wdReplaceOne
      End If
Next
End With
Doc.Content.InsertAfter vbCrLf & myInfo  '在新文档结尾插入对照记录
Doc.Activate
Application.ScreenUpdating = True
MsgBox "提取结果及题号对照记录见新文档。"
End Sub

sylun · 发表于 2010-6-23 20:55

原帖由 tangqingfu 于 2010-6-23 20:08 发表
试修改sylun兄2楼的代码，预适合随机抽取各小题前均为无答案时的题目，但获得的只是抽取记录，而没有题目。不知问题出在哪里，要如何修改？
...

问题出在如下这行：
.Text = "^13" & Num(i) & "、"
此时查找代码组合含义会发生变化（可查看查找替换关于ASCII 字符的项目代码解释）。可以用查找表达式的方法解决，即：
.Text = "(^13)" & Num(i) & "、"

		自动登录	找回密码
密码			免费注册

[求助] 如何在word格式题库中随机抽取部分题目形成试卷

评分

回复 2楼 sylun 的帖子