|
|
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 |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2008-12-26 13:17
楼主
