我的妻子是一名教授，我发现她已经手动创建她的测试的随机版本（以减少作弊）手工多年，以及她所在部门的所有其他教师。她使用Word 2007和2010来编写测试，所以我开始编写一个VBA宏来为她做这个繁琐的过程。
她的测试包括图像，列表和其他格式，因此直接文本复制不起作用。所有引用相同图像的问题都在同一页面上，否则每个问题都会得到它自己的页面。第一页包含说明，需要包含在随机测试文档的开头，但所有其他页面需要在新文档中随机化。在随机化过程之后，我将删除分页符，以便在尽可能少的页面上整齐地提出问题。
到目前为止，我还无法将从Page集合中获取的范围传输到新文档而不会丢失格式信息。我已经用谷歌搜索了所有地方，但我还没有发现任何迹象表明我做错了。
到目前为止我的代码：
Sub CreateTestVersions()
Dim ThisDoc As Document
Dim NewDoc As Document
Dim Pgs As pages
Dim Question As Range
Let Skip = 1 'Number of pages to skip randomizing
Set ThisDoc = Application.ActiveDocument
Set NewDoc = Documents.Add 'Create new document
Set Pgs = ThisDoc.Windows(1).Panes(1).pages 'Pages collection
ReDim Questions(1 To Pgs.Count - Skip) As Range
For p = 1 To Skip 'Add skipped pages to begining of new document
NewDoc.Content = NewDoc.Content & Pgs(p).Rectangles(1).Range
Next
' Add questions to an array of ranges
For q = LBound(Questions) To UBound(Questions)
Set Question = Pgs(q + Skip).Rectangles(1).Range
'Keep questions on a single page, don't split accross pages
Question.Paragraphs.KeepTogether = True
' All lists, text formatting, etc. is lost for some reason
Set Questions(q) = Question ' Needs fixed
Next
'Randomization needs to happen here
'Add randomized questions to new document
For q = LBound(Questions) To UBound(Questions)
NewDoc.Content = NewDoc.Content & Questions(q)
Next
'Remove page breaks
With NewDoc.Content.Find
.Text = "^m"
.Forward = True
.Wrap = wdFindStop
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End Sub
我正在使用Questions数组，因为我认为随机化更容易，特别是当我扩展此代码以生成多个版本时。我还想尽量避免使用选择，复制，粘贴。
对于我为何失去格式以及应采取何种正确方法的任何见解表示赞赏。
答案 0 :(得分：1)
我确实设法使用InsertFile并在每个问题周围添加远程书签。这是成品。希望它会帮助其他人！
Sub CreateTestVersions()
Dim ThisDoc As Document
Dim NewDocs() As Document
Dim Pgs As pages
Dim Question As Range
Dim skip As Variant
Dim versions As Variant
Dim Vers() As Integer
Dim qList As String
Dim numQs As Integer
Dim bound() As String
Dim fileName() As String
Dim pages As Integer
Dim minPages As Integer
Dim tryAgain As Boolean
Dim all As Range
Set ThisDoc = Application.ActiveDocument
Set Pgs = ThisDoc.ActiveWindow.Panes(1).pages 'Pages collection
'Number of pages to skip randomizing
skip = InputBox( _
"Each question should be on its own page, " _
& "unless that question shares a connection with another " _
& "(e.g. they share an image reference). You can separate " _
& "them using CTRL-Enter or Insert Page Break." & vbNewLine & vbNewLine _
& "How many pages belong at the beginning of every version " _
& "(instructions, personal data, etc.)?", "Question", 1)
If skip = "" Then Exit Sub
versions = InputBox("How many versions would you like to produce?", "Question", 4)
If versions = "" Then Exit Sub
numQs = Pgs.Count - skip
qList = InputBox(numQs & " question pages detected. Please list which questions" _
& " you want to use, with ranges denoted with dashes and gaps by commas" _
& " (e.g. 1-5, 9, 12-20).", "Question", "1-" & numQs)
If qList = "" Then Exit Sub
ReDim NewDocs(1 To versions) As Document
ReDim Vers(1 To versions) As Integer
For v = 1 To versions
'Create new document(s)
Set NewDocs(v) = Documents.Add
Vers(v) = v
Next
ReDim Indexes(1 To numQs) As Long
qList = Replace(qList, " ", "")
RangeList = Split(qList, ",")
numQs = 0
For Each rng In RangeList
bound = Split(rng, "-")
For i = bound(LBound(bound)) To bound(UBound(bound))
numQs = numQs + 1
Indexes(numQs) = i
Next
Next
ReDim Preserve Indexes(1 To numQs) As Long
ReDim Questions(1 To numQs) As Range
' Add questions to an array of ranges
For Each q In Indexes
If (Not ThisDoc.Bookmarks.Exists("Question " & q)) Then
ThisDoc.Bookmarks.Add "Question" & q, _
Pgs(q + skip).Rectangles(1).Range
End If
Next
minPages = Pgs.Count
Randomize
Do
For Each v In Vers
'Clear new document in case we are retrying for a shorter version
Set all = NewDocs(v).Content
all.WholeStory
all.Select
Selection.Delete
'Add skipped pages to begining of new document
If (Not ThisDoc.Bookmarks.Exists("Introduction")) Then
ThisDoc.Bookmarks.Add "Introduction", _
ThisDoc.Range(Pgs(1).Rectangles(1).Range.Start, _
Pgs(skip).Rectangles(1).Range.End)
End If
NewDocs(v).Content.InsertFile ThisDoc.FullName, "Introduction"
'Generate random indexs
For i = numQs To 2 Step -1
r = Int(Rnd() * (i - 2)) + 1
temp = Indexes(r)
Indexes(r) = Indexes(i)
Indexes(i) = temp
Next i
'Add randomized questions to new document
For q = LBound(Questions) To UBound(Questions)
i = Indexes(q)
Set Question = NewDocs(v).Content
Question.Collapse Direction:=wdCollapseEnd
Question.InsertFile ThisDoc.FullName, "Question" & i
Set Question = NewDocs(v).Range(Question.Start, NewDocs(v).Range.End)
Question.Paragraphs.KeepWithNext = True
NewDocs(v).Bookmarks.Add "Question" & i, Question
Next
'Remove page breaks
With NewDocs(v).Content.Find
.Text = "^m"
.Forward = True
.Wrap = wdFindContinue
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
'Group questions within pages, not accross them
For Each Bookmark In NewDocs(v).Bookmarks
Bookmark.Range.Paragraphs.Last.KeepWithNext = False
Next
pages = NewDocs(v).Windows(1).Panes(1).pages.Count
If pages < minPages Then minPages = pages
Next
' If all pages are not minimum length then try again
tryAgain = False
For Each v In Vers
pages = NewDocs(v).Windows(1).Panes(1).pages.Count
If pages > minPages Then tryAgain = True
Next
Loop While tryAgain
For Each v In Vers
'Save Document
fileName = Split(ThisDoc.Name, ".")
file = fileName(0)
ext = fileName(1)
NewDocs(v).SaveAs2 _
fileName:=file & " Version " & v & "." & ext, _
CompatibilityMode:=wdCurrent
Next
ThisDoc.Activate
End Sub