选枝随机、答案调整，已解决。

wdpfox

好的，是我没有看清测试文档的格式要求。

sylun

以下代码是对6楼代码的调整，亦可用于对有制表符分隔的选项及没有解析文本的题目，只作了简单测试

1. Dim answer As String
   
2. Sub test2()
   
3.     '随机重排题目与选项。题目每个选项可单独一段，或以制表符分隔
   
4.     Dim i As Integer
   
5.     Dim j As Integer
   
6.     Dim oText As String
   
7.     Dim regEx As Object
   
8.     Dim Match As Object
   
9.     Dim data() As String   '原数据
   
10.     Dim data2() As Variant '随机重排后数据
    
11.     Dim r As Variant
    
12.     Dim oDoc As Document
    
13.    
    
14.     Set oDoc = ActiveDocument
    
15.     oText = oDoc.Content.Text
    
16.     Set regEx = CreateObject("vbscript.regexp")
    
17.     With regEx
    
18.         .Global = True:
    
19.         .MultiLine = True
    
20.         .Pattern = "(^\d+)([\.．、][^\r]*[\(（])([A-Z])([\)）]\r)(([A-Z][\.．、][^\r\t]*[\r\t])+)(【解析】[^\r]+\r)?"
    
21.         For Each Match In .Execute(oText)
    
22.             ReDim Preserve data(8, i)
    
23.             For j = 0 To 4
    
24.                 data(j + 1, i) = Match.Submatches(j)
    
25.             Next
    
26.             data(6, i) = Match.Submatches(6) '解析，一个段落，可以没有解析部分
    
27.             data(7, i) = myOptions(data(3, i), data(5, i), Replace(data(6, i), Chr(13), ""))
    
28.             data(8, i) = answer
    
29.             i = i + 1
    
30.         Next
    
31.     End With
    
32.    
    
33.     r = Randomizing(UBound(data, 2))
    
34.     ReDim data2(UBound(r))
    
35.     For i = 0 To UBound(r)
    
36.         data2(i) = i + 1 & data(2, r(i)) & data(8, r(i)) & data(4, r(i)) & data(7, r(i))
    
37.     Next
    
38.    
    
39.     Documents.Add.Content.Text = Replace(Join(data2, vbCrLf), Chr(13) & Chr(13), Chr(13))
    
40.     MsgBox "共随机重排了" & i & "题。"
    
41. End Sub
    
42. 
    
43. Function Randomizing(n As Integer) As Variant
    
44.     '题号与选项顺序随机调整
    
45.     Dim c As Integer
    
46.     Dim d As Object
    
47.    
    
48.     Set d = CreateObject("Scripting.Dictionary")
    
49.     Randomize
    
50.     Do Until d.Count = n + 1
    
51.         c = Int(Rnd * (n + 1))
    
52.         d(c) = ""
    
53.     Loop
    
54.     Randomizing = d.Keys
    
55. End Function
    
56. 
    
57. Function myOptions(mydata1 As String, mydata2 As String, mydata3 As String) As String
    
58.     '选项与解析重排，传递参数依次为答案、选项和解析文本
    
59.     Dim i As Integer
    
60.     Dim n As Integer
    
61.     Dim t1() As String
    
62.     Dim t2() As String
    
63.     Dim k
    
64.    
    
65.     Do While InStr(mydata2, vbTab & vbTab) > 0
    
66.         mydata2 = Replace(mydata2, vbTab & vbTab, vbTab)
    
67.     Loop
    
68.     If InStr(mydata2, vbTab) > 0 Then mydata2 = Replace(mydata2, Chr(13), vbTab)
    
69.     t1 = Split(mydata2, IIf(InStr(mydata2, vbTab) = 0, Chr(13), Chr(9)))
    
70.     n = UBound(t1) - 1
    
71.     k = Randomizing(n)
    
72.     answer = Chr(k(Asc(mydata1) - 65) + 65)
    
73.     For i = 0 To UBound(k)
    
74.         t1(i) = Replace(Chr(k(i) + 65) & Mid(t1(i), 2), Chr(13), "")
    
75.     Next
    
76.     ReDim Preserve t1(UBound(k))
    
77.     WordBasic.SortArray t1 '排序
    
78.    
    
79.     If mydata3 <> Empty Then t2 = Explain(k, mydata3)
    
80.     myOptions = Join(t1, IIf(InStr(mydata2, vbTab) = 0, Chr(13), Chr(9))) & IIf(mydata3 <> Empty, vbCrLf & "【解析】", "") & Join(t2, "")
    
81. End Function
    
82. 
    
83. Function Explain(k As Variant, t As String) As Variant
    
84.     '处理解析文本。假设除选项字母外没有相同的单独选项字母
    
85.     Dim i As Integer
    
86.     Dim j As Integer
    
87.     Dim regEx As Object
    
88.     Dim Match As Object
    
89.     Dim sb() As Long
    
90.     Dim atext() As String
    
91.    
    
92.     Set regEx = CreateObject("vbscript.regexp")
    
93.     With regEx
    
94.         .Global = True:
    
95.         .MultiLine = True
    
96.         .Pattern = "(\b[A-Z]\b)([^A-Z\r\t]+)"
    
97.         For Each Match In .Execute(t)
    
98.             With Match
    
99.                 For j = 0 To UBound(k)
    
100.                     If Chr(j + 65) = .Submatches(0) Then
     
101.                         t = Left(t, .FirstIndex - 1) & Replace(t, .Submatches(0), Chr(k(j) + 65), .FirstIndex, 1)
     
102.                         ReDim Preserve sb(i)
     
103.                         sb(i) = .FirstIndex
     
104.                         Exit For
     
105.                     End If
     
106.                 Next
     
107.             End With
     
108.             i = i + 1
     
109.         Next
     
110.     End With
     
111.     For i = 0 To UBound(sb)
     
112.         ReDim Preserve atext(i)
     
113.         If i <> UBound(sb) Then atext(i) = Mid(t, sb(i) + 1, sb(i + 1) - sb(i)) Else atext(i) = Mid(t, sb(i) + 1)
     
114.     Next
     
115.     WordBasic.SortArray atext
     
116.     Explain = atext
     
117. End Function

复制代码

wdpfox

谢谢谢谢，老师的助人与分享精神令人钦佩，虽然我水平低，看不懂，但祝好人康安！手机回复，无法评分，后补。

weiyingde

sylun 发表于 2020-4-18 23:17
以下代码是对6楼代码的调整，亦可用于对有制表符分隔的选项及没有解析文本的题目，只作了简单测试

sylun大侠，我另开一贴，解决一一个小问题，请移步搭手相助。
先谢了。
http://club.excelhome.net/thread-1534895-1-1.html

ggmmlol

标准化题库的设计，对于进入题库的题目本身是有格式要求的，那就是“一致”，也就是说：要符合某个“标准化命题规范”，凡是要进入题库的题目，必须要先通过“合规”审核筛选，对于不合规的内容，需要打回去返工处理。

总之，“系统”的问题，首先要用“系统”的方法解决，这才是正道。
比如，解决本问题的“系统方法”，首先是要编制一个“标准化命题规范”，其次是对题库内容的审核和筛选，最后才谈得上设计一个“题库系统”进行自动化随机命题的必要。

此外，“系统”有容易固化的通病，所以，要尽量建立一个适应能力强的系统，这样一来，“系统”的标准就最为至关重要，这个道理就象通信业的3G\4G\5G标准的代际竞争以及同代的国产和外国标准之争一样，在同一个时间节点，扩展能力强的标准通常更容易推广。

weiyingde

谢谢指教，大虾所言极是。
一个合乎规范的题库确实重要，它使后续的处理变得容易和高效，这是毋庸置疑的。只可惜这个不是很规范的题库早已有之，如果不考虑解析部分，倒也十分好用。删除解析部分，程序能完全合乎我的要求，这在我的另一贴已经实现。但解析本就是题目的有机组成部分，删去岂不是踩背治坨，毫无意义。如果再规范试题库，只能一个一个地手动处理，繁琐至极，叫人不甘。这真是鸡肋……所以请大虾就本例深入看下，看是否有解决方案，挽救本程序功成于一篑

weiyingde

谢谢以上各位，在大家的启发和点拨下，穷根究底，反复尝试，已经完美解决了问题。再次谢谢各位的帮助，谢谢。
谢谢duquancai大侠的原始代码和思路，
谢谢sylun大侠的热心帮助，
谢谢ggmmlol大侠的指导。