Vba 如何将包含格式信息的范围以随机顺序从word文档中的页面传输到新word文档？

我的妻子是一名教授，我发现她多年来一直在手动创建随机版本的测试（以减少作弊），她所在系的所有其他教员都是如此。她使用Word2007和2010来编写测试，所以我开始编写一个VBA宏来为她完成这个繁琐的过程

她的测试包括图像、列表和其他格式，所以直接复制文本是行不通的。所有引用相同图片的问题都在同一页上，否则每个问题都会有自己的页面。第一页包含说明，需要包含在随机测试文档的开头，但所有其他页面都需要随机添加到新文档中。在随机化过程之后，我将删除分页符，以便问题尽可能整齐地放在尽可能少的页面上

到目前为止，我无法在不丢失格式信息的情况下将页面集合中的范围传输到新文档。我在谷歌上搜索了所有地方，但还没有找到任何迹象表明我做错了什么

到目前为止，我的代码是：

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

我使用问题数组是因为我认为这将更容易随机化，特别是当我扩展此代码以生成多个版本时。我还希望尽可能避免使用选择、复制、粘贴

---

任何关于我丢失格式的原因和正确方法的见解都值得赞赏。

我使用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

Sub-CreateTestVersions（）
将此文档设置为文档
Dim NewDocs（）作为文档
将Pgs设置为页面
作为范围的模糊问题
变光跳过
作为变体的Dim版本
Dim Vers（）作为整数
Dim qList作为字符串
作为整数的Dim numQs
Dim bound（）作为字符串
Dim fileName（）作为字符串
将页面设置为整数
将页面设置为整数
Dim tryAgain作为布尔值
调暗所有As范围
设置ThisDoc=Application.ActiveDocument
设置Pgs=ThisDoc.ActiveWindow.Panes（1）.页面的页面集合
'要跳过随机化的页数
跳过=输入框（_
“每个问题都应该在自己的页面上，”_
&“除非该问题与另一个问题有关联”_
&“（例如，它们共享一个图像引用）。您可以分离”_
&“使用CTRL键输入或插入分页符将其删除。”&vbNewLine&vbNewLine_
&“每个版本的开头有多少页”_
&“（说明、个人资料等？”，“问题”，1）
如果skip=”“，则退出Sub
版本=输入框（“您希望生成多少版本？”，“问题”，4）
如果版本=”，则退出Sub
numQs=Pgs.Count-跳过
qList=InputBox（numQs&“检测到问题页面。请列出哪些问题”_
&要使用，范围用破折号表示，间隔用逗号表示_
&“（例如1-5、9、12-20）。”、“问题”、“1-”和numQs）
如果qList=“”，则退出Sub
将新文档（1到版本）作为文档进行重拨
将版本（1到版本）重新定义为整数
对于v=1到v版本
'创建新文档
设置新文档（v）=文档。添加
Vers（v）=v
下一个
ReDim索引（1到numQs）的长度
qList=Replace（qList，“，”）
RangeList=Split（qList，“，”）
numQs=0
对于范围列表中的每个rng
绑定=拆分（rng，“-”）
对于i=绑定（LBound（bound））到绑定（UBound（bound））
numQs=numQs+1
索引（numQs）=i
下一个
下一个
ReDim将索引（1到numQs）保留为
重拨问题（1到numQs）作为范围
'将问题添加到范围数组中
对于索引中的每个q
如果（不是ThisDoc.Bookmarks.Exists（“问题”&q）），那么
ThisDoc.Bookmarks.Add“Question”&q_
Pgs（q+跳过）。矩形（1）。范围
如果结束
下一个
minPages=Pgs.Count
随机化
做
对于每一个v
'清除新文档，以防我们重新尝试较短的版本
Set all=NewDocs（v）.内容
健康的
全部。选择
选择。删除
'将跳过的页面添加到新文档的开头
如果（不是ThisDoc.Bookmarks.Exists（“简介”）），那么
ThisDoc.Bookmarks.Add“简介”_
ThisDoc.Range（Pgs（1）.矩形（1）.Range.Start_
Pgs（跳过）。矩形（1）。范围。结束）
如果结束
NewDocs（v）.Content.InsertFile ThisDoc.FullName，“简介”
'生成随机索引
对于i=numQs到2步骤-1
r=Int（Rnd（）*（i-2））+1
温度=索引（r）
索引（r）=索引（i）
索引（i）=温度
接下来我
'将随机问题添加到新文档中
对于q=LBound（问题）到UBound（问题）
i=索引（q）
设置问题=NewDocs（v）.内容
问题.折叠方向：=wdCollapseEnd
Question.InsertFile ThisDoc.FullName，“问题”&i
Set Question=NewDocs（v）.Range（Question.Start，NewDocs（v）.Range.End）
Question.parations.KeepWithNext=True
NewDocs（v）.Bookmarks.Add“Question”&i，Question
下一个
'删除分页符
使用NewDocs（v.Content.Find）
.Text=“^m”
.Forward=True
.Wrap=wdFindContinue
.Replacement.Text=“”
.Execute Replace:=wdReplaceAll
以
“在页面内分组问题，而不是交叉提问
对于NewDocs中的每个书签（v）.书签
Bookmark.Range.parations.Last.KeepWithNext=False
下一个
pages=NewDocs（v）.Windows（1）.窗格（1）.pages.Count
如果pagesminPages，则tryAgain=True
下一个
边转边转
对于每一个v
的