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

weiyingde · 发表于 2020-4-12 20:16

本帖最后由 weiyingde 于 2020-5-6 07:31 编辑

声明：
1、下面的程序代码原创始于duquancai杜大侠，见http://club.excelhome.net/thread-384424-1-2.html第五楼
创意亦始于sylun大侠的“试卷试题随机排序”的帖子。见http://club.excelhome.net/thread-385342-1-1.html，所以这个帖子，不是我的原创作品。
2、sylun大侠的代码，比较复杂，想探究，终因缺乏耐心而未能卒读；杜大侠的代码精练、流畅，作为我首选学习模仿；但杜大侠的代码只有一项功能，不能完全实现我的要求。所以，我在他的代码基础上加以补充，实现了更新调整答案，可就在实现更新“【解析】”中序号的时候又卡壳了……
3、这个帖子是http://club.excelhome.net/thread-1530951-1-1.html帖子的延续，本该在该帖子下继续跟帖，又怕因此而泥牛入海，杳无音信……为吹箫引凤，只好另外开贴。
4、本帖子虽是改编，但由于本人半路出家、才疏学浅、思维缓慢闭塞……到目前程度，几历构思、修改、调试……已经花费了两天时间，至此环节，山穷水尽……期盼高人行家指点，帮老朽走出迷宫……

再次期盼大侠的出现………………………………

代码如下:

Sub 综合简约实验版()
Dim mt, mk, oRng As Range, n&, m&, str$, TT$
Dim rg As Range, arr(), x%, d As Object, k&, ar, rng1 As Range, rng2 As Range
Set d = CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
Set RegE = CreateObject("vbscript.regexp")
RegE.Pattern = "[$（][A-Z]{1,}[$）](?:\r)"
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "【解析】.*"
RegX.Global = False
On Error Resume Next

str = Replace(ActiveDocument.Content, Chr(7), "")
With CreateObject("vbscript.regexp")
      .Global = True: .IgnoreCase = False: .MultiLine = True

      Rem 说明:
      Rem 下面的.Pattern用非注释的能顺利实现：
      Rem ⑴选枝随机；⑵括号的答案能顺利与随机选枝做相应调整更新。
      Rem  遗憾：不能实现【解析】里出现的编号（A.B.C.D）不能与选枝作相应调整。
      Rem  原因：为了实现实现上面的两项功能，故意屏蔽了【解析】段，带来RegX.Pattern = "【解析】.*"不能匹配到目标。
      Rem  探索:将下面两处的注释和非注释轮换如何？出现两个问题。
      Rem    ⑴程序假死，大概是死循环；显然是调整更新【解析】处出了问题，将其注释或删除如何？
      Rem    ⑵出现随机后的部分选枝残缺或混乱，显然又是定位出了问题。
      Rem  针对这些情况，请路过行家、大侠指教或搭手相助。

      .Pattern = "^\d+[\.．][^\r]*[$（]([A-Z])[$）]\r(?:(?!(^\d+[\.．]|^【解析】)).)+" '
      Rem .Pattern = "^\d+[\.．][^\r]*[$（]([A-Z])[$）]\r(?:(?!(^\d+[\.．])).)+"
      For Each mt In .Execute(str)

         sr1 = mt.submatches(0)
         m = mt.firstindex: n = mt.Length
         Set oRng = ActiveDocument.Range(m, m + n)

         fst = RegE.Execute(oRng)(0).firstindex
         lth = RegE.Execute(oRng)(0).Length
         Set rng1 = ActiveDocument.Range(oRng.Start + fst, oRng.Start + fst + lth)
         If Right(rng1.Text, 1) = vbCr Then rng1.End = rng1.End - 1

         Rem 下面.Pattern与上面.Pattern相配合使用，出现的问题同上。
         Rem .Pattern = "[A-Z]+[\.．]((?!([A-Z][\.．]|【解析】)).)+"
         .Pattern = "[A-Z]+[\.．]((?![A-Z][\.．]).)+"
         TT = Replace(oRng.Text, Chr(7), "")
         For Each mk In .Execute(TT)
            sr2 = Left(mk, 1)
            m = mk.firstindex: n = mk.Length
            Set rg = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n)
            rg.Start = rg.Start + 2: rg.End = rg.End - 1
            If Right(rg.Text, 1) = vbCr Then rg.End = rg.End - 1
            x = x + 1: k = k + 1: ReDim Preserve arr(1 To x)
            arr(x) = rg.Text: Set d(k) = rg
         Next

         If x > 0 Then '随机选枝
            ar = Rndcq(arr, x)
            For i = 0 To d.Count - 1
                  d.Items()(i).Text = ar(i + 1)
            Next
         End If

         DaId = Asc(Mid(rng1.Text, 2, 1)) - 64 '更新答案
         For i = 1 To UBound(ar)
            If ar(i) = arr(DaId) Then srr = Chr(64 + i): Exit For
         Next
         rng1.Text = "(" & srr & ")"

         For i = 1 To UBound(arr)
            For j = 1 To UBound(ar)
               If ar(i) = arr(j) Then dic(Chr(i + 64)) = Chr(j + 64)
            Next
         Next
         ky = dic.Keys
         tm = dic.Items

         If RegX.test(TT) = True Then '调整更新【解析】中出现的A、B、C、D编号
         Rem 更新解析，运行到此处时，程序出现死循环，我自认为思路是不错的，可能是区域需要调整
         Rem 以前出现这个问题，此处保不定还是这个问题，可需要添加代码，由于学艺不精，不知所然。
         Rem 请大侠在此处多看看。
            ftdx = RegX.Execute(TT)(0).firstindex
            lgth = RegX.Execute(TT)(0).Length
            Set rng2 = ActiveDocument.Range(oRng.Start + ftdx, oRng.Start + ftdx + lgth)
            If Right(rng2.Text, 1) = vbCr Then rng2.End = rng2.End - 1
            With rng2.Find
                  For i = 0 To dic.Count - 1
                     Do While .Execute([A-Z], , , 1)
                        With .Parent
                              If .Text = ky(i) Then .Text = tm(i)
                              .Collapse
                        End With
                     Loop
                  Next
            End With
         End If

         x = 0: k = 0: d.RemoveAll: dic.RemoveAll
      Next
End With
End Sub

Function Rndcq(arr, r As Integer)
Dim arr1(), arr2%(), sr%, x%, y%, num%, k%
k = UBound(arr)
ReDim arr2(1 To k): ReDim arr1(1 To r)
For y = 1 To k
      arr2(y) = y
Next
Randomize
For x = 1 To r
      num = (Rnd() * ((k - x + 1) - 1) + 1) \ 1
      arr1(x) = arr(arr2(num))
      sr = arr2(num)
      arr2(num) = arr2(k - x + 1)
      arr2(k - x + 1) = sr
Next x
Rndcq = arr1
End Function

wdpfox · 发表于 2020-4-12 23:24

魏老师的功底不浅，能研懂并应用杜老师的代码实属不易，是我等小白学习的典范。

weiyingde · 发表于 2020-4-13 12:32

再次救助，希望大侠路过搭手相助。

weiyingde · 发表于 2020-4-13 18:34

本帖最后由 weiyingde 于 2020-4-13 19:41 编辑

自我检查，在下面的代码中添加了红色代码，仍没有理想结果。
            If Right(rng2.Text, 1) = vbCr Then rng2.End = rng2.End – 1
            Set myParRange = rng2.Paragraphs(1).Range.Duplicate
            With rng2.Find
                  For i = 0 To dic.Count - 1
                     Do While .Execute([A-Z], , , 1)
                        With .Parent
                              If Not .InRange(myParRange) Then Exit Do
                              If .Text = ky(i) Then .Text = tm(i)
仍然是死循环，不知为何……
潘大侠支招》》》》》

weiyingde · 发表于 2020-4-13 22:22

再次求援，望高手赐教，谢谢

sylun · 发表于 2020-4-14 00:27

可试试如下代码（对原文本有要求），较复杂，只作字符处理，代码较长。

Option Explicit
Dim answer As String
Sub test()
Dim i As Integer
Dim oText As String
Dim regEx As Object
Dim Match As Object
Dim data() As String '原数据
Dim data2() As Variant '随机重排后数据
Dim r As Variant
Dim oDoc As Document
Set oDoc = ActiveDocument
oText = oDoc.Content.Text
Set regEx = CreateObject("vbscript.regexp")
With regEx
.Global = True:
.MultiLine = True
.Pattern = "(^\d+)([\.．、][^\r]*[$（])([A-Z])([$）]\r)(([A-Z][\.．、][^\r]*\r)*)(【解析】[^\r]+\r)"
For Each Match In .Execute(oText)
ReDim Preserve data(8, i)
data(0, i) = Match.Value
data(1, i) = Match.Submatches(0) '题号
data(2, i) = Match.Submatches(1) '
data(3, i) = Match.Submatches(2) '答案
data(4, i) = Match.Submatches(3)
data(5, i) = Match.Submatches(4) '选项，假设每个选项单独一段
data(6, i) = Match.Submatches(6) '解析，一个段落
data(7, i) = myOptions(data(3, i), data(5, i), Replace(data(6, i), Chr(13), "")) '重排后选项与解释
data(8, i) = answer '重排后答案
i = i + 1
Next
End With
r = Randomizing(UBound(data, 2))
ReDim data2(UBound(r))
For i = 0 To UBound(r)
data2(i) = i + 1 & data(2, r(i)) & data(8, r(i)) & data(4, r(i)) & data(7, r(i))
Next
Documents.Add.Content.Text = Join(data2, vbCrLf)
End Sub
Function Explain(k As Variant, t As String) As Variant
'处理解析文本。假设除选项字母外没有相同的单独选项字母
Dim i As Integer
Dim j As Integer
Dim regEx As Object
Dim Match As Object
Dim sb() As Long
Dim atext() As String
Set regEx = CreateObject("vbscript.regexp")
With regEx
.Global = True:
.MultiLine = True
.Pattern = "(\b[A-Z]\b)([^A-Z\r]+)"
For Each Match In .Execute(t)
With Match
For j = 0 To UBound(k)
If Chr(j + 65) = .Submatches(0) Then
t = Left(t, .FirstIndex - 1) & Replace(t, .Submatches(0), Chr(k(j) + 65), .FirstIndex, 1)
ReDim Preserve sb(i)
sb(i) = .FirstIndex
Exit For
End If
Next
End With
i = i + 1
Next
End With
For i = 0 To UBound(sb)
ReDim Preserve atext(i)
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)
Next
WordBasic.SortArray atext
Explain = atext
End Function
Function Randomizing(n As Integer) As Variant
'题号与选项顺序随机调整
Dim c As Integer
Dim i As Integer
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Randomize
Do Until d.Count = n + 1
c = Int(Rnd * (n + 1))
d(c) = ""
Loop
Randomizing = d.Keys
End Function
Function myOptions(mydata1 As String, mydata2 As String, mydata3 As String) As String
'选项与解析重排
Dim c As Integer
Dim i As Integer
Dim n As Integer
Dim d As Object
Dim regEx As Object
Dim t1() As String
Dim t2() As String
Dim k
t1 = Split(mydata2, Chr(13))
n = UBound(t1) - 1
k = Randomizing(n)
answer = Chr(k(Asc(mydata1) - 65) + 65)
For i = 0 To UBound(k)
t1(i) = Chr(k(i) + 65) & Mid(t1(i), 2)
Next
ReDim Preserve t1(UBound(k))
WordBasic.SortArray t1
t2 = Explain(k, mydata3)
myOptions = Join(t1, Chr(13)) & vbCrLf & "【解析】" & Join(t2, "")
End Function

复制代码

zpy2 · 发表于 2020-4-14 05:50

楼主厉害了。。。

如果是我，一般都是专门把题目内容和选项放一个表，然后固定数目，比如4个选项，乱序，可能方便点，再生成试卷。。。

wdpfox · 发表于 2020-4-14 10:48

zpy2 发表于 2020-4-14 05:50
楼主厉害了。。。

如果是我，一般都是专门把题目内容和选项放一个表，然后固定数目，比如4个选项，乱 ...

是一个解决方案。

莫愁前路无知己，天下谁人不识君！只道是：海内存知己，天涯若比邻！

weiyingde · 发表于 2020-4-14 11:37

sylun 发表于 2020-4-14 00:27
可试试如下代码（对原文本有要求），较复杂，只作字符处理，代码较长。

喜出望外，担心泥牛入海，谁想这么快就有结果了！太感谢你了。

weiyingde · 发表于 2020-4-14 11:42

sylun 发表于 2020-4-14 00:27
可试试如下代码（对原文本有要求），较复杂，只作字符处理，代码较长。

sylun大侠，另起炉灶，这下老牛又有草料了，我可能要反刍好几天了

。
不过，今天我先测试，有问题，还要向你请教

若是再麻烦你，请你忍耐！海涵！！帮助！！！

再次谢谢你！！！

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

[分享] 选枝随机、答案调整，已解决。

评分