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