vba 如何在 Microsoft Word 中随机化一个列表？

How can you randomize a list in Microsoft Word?

提问by Mitchell Dueck

I am a teacher and I have been making a number of multiple choice tests for students using Microsoft Word. Is there a way for me to automatically shuffle the questions so that I can have multiple versions of the test without needing to copy and paste the questions around my test? Looking online I found a one solution posted by Steve Yandl in which he used macro after putting each question on a separate row in a table. I am trying to get his macro to work but it has and error. I know next to nothing about coding, so I am stuck. Here is his code:

我是一名教师，我一直在为使用 Microsoft Word 的学生进行多项选择题测试。有没有办法让我自动随机排列问题，以便我可以拥有多个版本的测试，而无需在我的测试中复制和粘贴问题？在网上查看我找到了 Steve Yandl 发布的一个解决方案，其中他在将每个问题放在表格中的单独一行之后使用了宏。我试图让他的宏工作，但它有错误。我对编码几乎一无所知，所以我被困住了。这是他的代码：

Sub ShuffleQuestions()

Dim Tmax As Integer
Dim strCell As String
Dim strQ As Variant
Dim strText As String
Dim I As Integer
Dim Z As Integer
Dim intQsLeft As Integer
Dim rndQ As Integer
Dim Q As Integer
Dim vArray As Variant
Dim strNew As String

Set objDict = CreateObject("Scripting.Dictionary")

Tmax = ThisDocument.Tables(1).Rows.Count

For I = 1 To Tmax
strCell = ThisDocument.Tables(1).Cell(I, 1).Range.Text
strQ = Left(strCell, Len(strCell) - 1)
objDict.Add strQ, strQ
Next I

ReDim arrQs(I - 1)

intQsLeft = I - 2
Z = 0


Do While intQsLeft = 0
Randomize
rndQ = Int((intQsLeft + 1) * Rnd)
intQsLeft = intQsLeft - 1
vArray = objDict.Items
strText = vArray(rndQ)
arrQs(Z) = strText
Z = Z + 1
objDict.Remove strText
Loop

For Q = 1 To Tmax
strNew = arrQs(Q - 1)
strNew = Left(strNew, Len(strNew) - 1)
ThisDocument.Tables(1).Cell(Q, 1).Range.Text = strNew
Next Q


End Sub

The error message I get says "run time error 5941 the requested member of the collection does not exist" When I choose the 'Debug' button it brings me to the line of code in the macro that says "Tmax = ThisDocument.Tables(1).Rows.Count"

我收到的错误消息说“运行时错误 5941 所请求的集合成员不存在”当我选择“调试”按钮时，它会将我带到宏中的代码行“Tmax = ThisDocument.Tables(1 ).Rows.Count"

Ultimately I just want to reorder the questions, but I would be delighted if there was also a way to reorder my multiple choice options for each question.

最终，我只想对问题重新排序，但如果还有一种方法可以为每个问题重新排序我的多项选择选项，我会很高兴。

回答by grantnz

Does your document have a table?

你的文件有表格吗？

Where did you put the sub (ShuffleQuestions)?

你把 sub (ShuffleQuestions) 放在哪里了？

Are you sure you added it to your document and didn't add it to the document template (probably normal).

你确定你把它添加到你的文档中而不是将它添加到文档模板中（可能是正常的）。

If, after running the code, reaching the error and clicking debug, you highlight ThisDocument.Tables, right clicking on the highlighted text and select "Add Watch" from the popup menu you should be able to see if ThisDocument.Tables contains any data.

如果在运行代码后出现错误并单击调试，您突出显示 ThisDocument.Tables，右键单击突出显示的文本并从弹出菜单中选择“添加监视”，您应该能够查看 ThisDocument.Tables 是否包含任何数据。

I suspect it will be empty. It will be empty if:

我怀疑它会是空的。如果出现以下情况，它将为空：

1. You haven't added a table to your document
2. You have added the sub to normal.dot in which case ThisDocument will refer to the normal template and not the document you are actually editing.

1. 您尚未在文档中添加表格
2. 您已将 sub 添加到 normal.dot 在这种情况下 ThisDocument 将引用普通模板而不是您实际正在编辑的文档。

So, the solution is either:

因此，解决方案是：

1. Make sure your sub is in the document you are editing (and not the document template)
2. That you have a table in your document.

1. 确保您的子文件在您正在编辑的文档中（而不是文档模板）
2. 您的文档中有一个表格。

There are also some programming errors in the sub ShuffleQuestions (e.g. Do While intQsLeft = 0 should be something like Do While intQsLeft > 0).

在子 ShuffleQuestions 中也有一些编程错误（例如 Do While intQsLeft = 0 应该类似于 Do While intQsLeft > 0）。

The following code works (and is a lot simpler):

以下代码有效（并且简单得多）：

Sub ShuffleQuestions()

Dim numberOfRows As Integer
Dim currentRowText As String
Dim I As Integer
Dim doc As Document


Set doc = ActiveDocument

'Find the number of rows in the first table of the document
numberOfRows = doc.Tables(1).Rows.Count
'Initialise (seed) the random number generator
Randomize
'For each row in the table
For I = 1 To numberOfRows
    'Find a new row number (any row in the table)
    newRow = Int(numberOfRows * Rnd + 1)
    'Unless we're not moving to a new row
    If newRow <> I Then
        'Get the current row text
        currentRowText = CleanUp(doc.Tables(1).Cell(I, 1).Range.Text)
        'Overwrite the current row text with the new row text
        doc.Tables(1).Cell(I, 1).Range.Text = CleanUp(doc.Tables(1).Cell(newRow, 1).Range.Text)
        'Put the current row text into the new row
        doc.Tables(1).Cell(newRow, 1).Range.Text = currentRowText
    End If
Next I

End Sub


Function CleanUp(value As String) As String
   'Remove control characters from the end of the string (the cell text has a 'BELL' character and CR at the end)
   While (Len(value) > 0 And Asc(Right(value, 1)) < 32)
        value = Left(value, Len(value) - 1)
   Wend
   CleanUp = value
End Function