|
|
试修改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 |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2008-11-26 12:02
楼主
