不改变题号，只改变选项内容顺序的代码

tangqingfu · 发表于 2008-12-26 13:17

如在英语题型完形填空中，题号是不能变的，能变的只能是选项A．B．C．D．内容（选项也可能只有A．B．C．三种），如何改变选项的内容，即在同一小题中变化其顺序，请教这样的代码该如何写？
注：①以上选择题题号后面的点均为“．”
②选项A．B．C．D．变化可以是部分变化，或全部变化（选项也可能只有A．B．C．三种）
③选项A．B．C．D．的点均为“．”

hao123 · 发表于 2008-12-26 20:33

看看先，应该是个好东东

hbyjwhj · 发表于 2009-1-31 16:13

怎么没代码

hhzjxss · 发表于 2017-1-3 15:32

我路过，看看而以，谢谢！

duquancai · 发表于 2017-1-4 16:34

本帖最后由 duquancai 于 2017-1-4 16:49 编辑

Sub 随机调换答案顺序()
Dim mt, mk, oRng As Range, n&, m&, str$
Dim rg As Range, arr(), x%, d As Object, k&, a
Set d = CreateObject("Scripting.Dictionary")
str = Replace(ActiveDocument.Content, Chr(7), "")
With CreateObject("vbscript.regexp")
.Global = True: .IgnoreCase = False: .MultiLine = True
.Pattern = "^\d+．\s*[A-Z]．[^\r]+"
For Each mt In .Execute(str)
m = mt.FirstIndex: n = mt.Length
Set oRng = ActiveDocument.Range(m, m + n)
.Pattern = "[^．\t\dA-Z]+"
For Each mk In .Execute(oRng.Text)
m = mk.FirstIndex: n = mk.Length
Set rg = ActiveDocument.Range(oRng.Start + m, oRng.Start + m + n)
x = x + 1: k = k + 1: ReDim Preserve arr(1 To x)
arr(x) = mk: Set d(k) = rg
Next
a = Rndcq(arr, x)
For i = 0 To d.Count - 1
d.items()(i).Text = a(i + 1)
Next
x = 0: k = 0: d.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

复制代码

tangqingfu · 发表于 2017-1-17 15:27

duquancai 发表于 2017-1-4 16:34

谢谢分享，收藏学习！

zhouguangcai · 发表于 2017-3-25 09:47

duquancai 发表于 2017-1-4 16:34

如果不是这种格式，代码有应该怎么写呢？请问大侠

duquancai · 发表于 2017-3-27 02:25

zhouguangcai 发表于 2017-3-25 09:47
如果不是这种格式，代码有应该怎么写呢？请问大侠

Sub 随机调换答案顺序2()
Dim mt, mk, oRng As Range, n&, m&, str$, TT$
Dim rg As Range, arr(), x%, d As Object, k&, a
Set d = CreateObject("Scripting.Dictionary")
str = Replace(ActiveDocument.Content, Chr(7), "")
With CreateObject("vbscript.regexp")
      .Global = True: .IgnoreCase = False
      .Pattern = "\d+[.。].+?(?=\d+[.。]|$)"
      For Each mt In .Execute(str)
         m = mt.FirstIndex: n = mt.Length
         Set oRng = ActiveDocument.Range(m, m + n)
         .Pattern = "[A-Z]+．((?![A-Z]．).)+"
         TT = Replace(oRng.Text, Chr(7), "")
         For Each mk In .Execute(TT)
            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) = vbTab Or Right(rg.Text, 1) = vbCr Then
                  rg.End = rg.End - 1
            End If
            x = x + 1: k = k + 1: ReDim Preserve arr(1 To x)
            arr(x) = rg: Set d(k) = rg
         Next
         If x > 0 Then
            a = Rndcq(arr, x)
            For i = 0 To d.Count - 1
                  d.items()(i).Text = a(i + 1)
            Next
         End If
         x = 0: k = 0: d.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

duquancai · 发表于 2017-3-27 02:36

zhouguangcai 发表于 2017-3-25 09:47
如果不是这种格式，代码有应该怎么写呢？请问大侠

附件，打开，点击按钮》》》》》》》》》》》》》》》》》》》》

tangqingfu · 发表于 2017-3-27 15:50

duquancai 发表于 2017-3-27 02:36
附件，打开，点击按钮》》》》》》》》》》》》》》》》》》》》

谢谢duquancai兄的分享！！

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

[求助] 不改变题号，只改变选项内容顺序的代码

评分

评分