word题库随机抽题测试程序

zhanglei1371

花了一上午时间写的，可以用于从word题库中抽题。
优点在于可以保留特殊格式。如图片，上下标等都可以得以保存。
根据Excel的设定来随机抽取章节题目；



★★★为查找标志，必须有。
使用时同时打开word和execl，点击按钮即可。


源码参考：

1. Sub 按Excel设定抽题()
   
2. Dim ex As Object, wb As Object, sh As Object, arr, brr, crr
   
3. Dim rg As Range, rg1 As Range, rg2 As Range, rgtmp As Range
   
4. Dim re As Object, TF As Boolean
   
5.     Set re = CreateObject("VBSCRIPT.regexp")
   
6.     re.Global = 1
   
7.     re.MultiLine = 1
   
8.     re.Pattern = "^\d+．"
   
9.     Set ex = GetObject(, "Excel.application")
   
10.     Set rg = ActiveDocument.Range
    
11.     For Each wb In ex.workbooks
    
12.         If InStr(wb.Name, "抽题") Then exname = wb.Name: Exit For
    
13.     Next
    
14.     For Each Doc In Documents
    
15.         If InStr(Doc.Name, "抽题") Then wdname = Doc.Name: Exit For
    
16.     Next
    
17.     Set docN = Documents.Add
    
18.     Set ADoc = Documents(wdname)
    
19.     Set sh = ex.workbooks(exname).worksheets(1)
    
20.     en_num = sh.Range("A635536").End(3).Row
    
21.     arr = sh.Range("A3:C" & en_num)
    
22.     For i = 1 To UBound(arr, 1)
    
23.         With rg.Duplicate.Find
    
24.             If .Execute("★★★" & arr(i, 1), , , 1) Then
    
25.                 st = .Parent.Start
    
26.                 .Parent.Collapse 0
    
27.                 If .Parent.Find.Execute("★★★") Then
    
28.                     Set rg1 = ADoc.Range(st, .Parent.End - 3)
    
29.                     total_tishu = re.Execute(rg1).Count
    
30.                     brr = 获取随机数(arr(i, 3), total_tishu)
    
31.                     With rg1.Find
    
32.                         For Each m In brr
    
33.                             If .Execute("(^13)" & m & "．" & "*参考答案[!^13]@^13", , , 1) Then
    
34.                                 If Not .Parent.InRange(rg1) Then MsgBox "查找的目标超出给定章节范围之外！": Exit Sub
    
35.                                 .Parent.MoveStart 1, 1
    
36.                                 docN.Bookmarks("\EndofDoc").Range.FormattedText = .Parent.FormattedText
    
37.                                 .Parent.MoveEnd 1, -1
    
38.                             End If
    
39.                             .Parent.Collapse 0
    
40.                         Next
    
41.                     End With
    
42.                 End If
    
43.             End If
    
44.         End With
    
45.     Next
    
46.     Set ex = Nothing
    
47.     MsgBox "恭喜,已完成!"
    
48. End Sub
    
49. 
    
50. Function 获取随机数(a, b)
    
51. Dim num()
    
52.     Randomize
    
53.     Do While n < CInt(a)
    
54.         ReDim Preserve num(n)
    
55.         temp = Int((b * Rnd) + 1)
    
56.         If n > 0 Then
    
57.             For i = 0 To UBound(num)
    
58.                 If num(i) = temp Then
    
59.                     TF = True
    
60.                     Exit For
    
61.                 End If
    
62.             Next
    
63.         End If
    
64.         If TF = False Then
    
65.             num(n) = temp
    
66.             n = n + 1
    
67.         End If
    
68.         TF = False
    
69.     Loop
    
70.    WordBasic.sortarray num
    
71.    获取随机数 = num
    
72. End Function
    

复制代码

附件：

不经意的回头

感谢楼主分享！

不经意的回头

测试运行提示下标越界。

zhanglei1371

不经意的回头 发表于 2018-9-11 13:22
测试运行提示下标越界。

那是你电脑问题。刚换了台电脑测试过，一切正常。

wdpfox

强！收藏学习，谢谢分享！

hcm19522

C2:C16=RAND()

D2:D16{=IF(C2>=LARGE((LOOKUP(ROW(A$2:A$16),ROW(A$2:A$16)/(A$2:A$16<>""),A$2:A$16)=LOOKUP(1,0/(A$2:A2<>""),A$2:A2))*C$2:C$16,VLOOKUP(LOOKUP(1,0/(A$2:A2<>""),A$2:A2),E:F,2)),"V","")

H2:H16{=IFERROR(INDEX(B:B,RIGHT(LARGE(IF(D$2:D$16="V",INT(C$2:C$16/1%)/1%+ROW(A$2:A$16)),ROW(A1)),2)),"")

ljbailin

老师，你好，帮我编一个抽题程序吧，我是小白

yhs185

楼主辛苦了   

thunor

楼主干得很好，佩服。

wawbt

感谢分享！

补充内容 (2019-7-31 15:31):
没有明白六楼的意思。还望指教。