如何使用vba将一个word文档的内容复制到另一个word文档的末尾？

Question

我的项目目标：

我希望能够复制一个文档的内容并将该选择附加到另一个文档的末尾。

它的作用 ...... （这只是背景信息，所以你理解我为什么要这样做）：

我正在尝试动态生成一个文档，该文档引用了有关产品所涉及的不同部件和材料的各种信息。

文档本身具有一致的格式，我将其分解为两个文档。 第一个包含需要手动输入的一堆数据，并且是我想要附加所有其他内容的地方。 第二个包含大约十几个自定义字段，这些字段是从VBA中的Excel电子表格更新的。 对于单个部分和单个文档，这可以按我的意愿工作（我的基本情况）。 但是我的问题是当项目有多个部分时。

问题：

对于多个部分，我必须将信息存储在一个数组中，该数组随着每个附加部分的添加而动态变化。 当有人添加了所有必要的部件后，他们可以选择一个名为“创建报价”的按钮。

创建报价运行一个过程，该过程创建/打开上述两个模板文档的单独副本（保存在我的计算机上）。 然后，它遍历部件数组并更新第二个文档中的所有自定义字段（没有问题）。 现在我只需要将第二个文档的内容添加到第一个文档的末尾，这是我的问题。

我想要的是：

理想情况下，我的过程将继续遍历数组中的每个部分 - 更新自定义字段，复制然后粘贴更新的文本，重复...直到每个部分都包含在新生成的引用中。

我尝试了什么 - 这个代码可以在我的生成报价程序中找到

我已经尝试了许多有类似问题的人提供的示例和建议，但我不知道是不是因为我是在excel doc上运行，但他们的许多解决方案对我没有用。

这是我最近的尝试，发生在for循环的每次迭代之后

        wrdDoc2.Fields.Update 'Update all the fields in the format document
        wrdDoc2.Activate

        Selection.WholeStory ' I want to select the entire document
        Selection.Copy ' Copy the doc

        wrdDoc1.Activate ' Set focus to the target document

        Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
        Selection.PasteAndFormat wdPasteDefault

引用程序 - 我只包括一些我正在更新的字段，因为没有必要全部显示它们

Private Sub quote_button_Click()

On Error GoTo RunError

    Dim wrdApp1, wrdApp2 As Word.Application
    Dim wrdDoc1, wrdDoc2 As Word.Document

    Set wrdApp1 = CreateObject("Word.Application")
    Set wrdApp2 = CreateObject("Word.Application")

    wrdApp1.Visible = True
    wrdApp2.Visible = True

    Set wrdDoc1 = wrdApp1.Documents.Add(Template:="C:\MWES\AQT_v1.1(start).docm", NewTemplate:=False, DocumentType:=0)
    Set wrdDoc2 = wrdApp2.Documents.Add(Template:="C:\MWES\AQT_v2.1(format).docm", NewTemplate:=False, DocumentType:=0)

    Dim propName As String

    For i = LBound(part_array, 1) To UBound(part_array, 1)
        For Each prop In wrdDoc2.CustomDocumentProperties

            propName = prop.name

            ' Looks for and sets the property name to custom values of select properties
            With wrdDoc2.CustomDocumentProperties(propName)
                Select Case propName
                    Case "EST_Quantity"
                        .value = part_array(i, 0) ' "QTY" ' Sheet1.Cells(1, 3) 'NA

                    Case "EST_Metal_Number"
                        .value = part_array(i, 1) ' "METAL_#" ' Sheet1.Cells(2, 3) 'NA"

                    Case "EST_Metal_Name"
                        .value = part_array(i, 2) ' "METAL_N" ' Sheet1.Cells(5, 2)

                End Select

            End With

        Next prop ' Iterates until all the custom properties are set

        wrdDoc2.Fields.Update 'Update all the fields in the format document
        wrdDoc2.Activate

        Selection.WholeStory ' I want to select the entire document
        Selection.Copy ' Copy the doc

        wrdDoc1.Activate ' Set focus to the target document

        Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
        Selection.PasteAndFormat wdPasteDefault

    Next i ' update the document for the next part

RunError: ' Reportd any errors that might occur in the system

    If Err.Number = 0 Then
        Debug.Print "IGNORE ERROR 0!"

    Else
        Dim strError As String
        strError = "ERROR: " & Err.Number & vbCrLf & Err.Description & vbCrLf & Erl
        MsgBox strError
        Debug.Print strError & " LINE: " & Erl

    End If

End Sub

我道歉这是如此漫长的啰嗦。 如果有任何令人困惑的事情或者您可能需要澄清，请告诉我。 我想我包括了一切。

Answer 1

我认为你很接近，所以这里有几条评论和一个例子。

首先，您将打开两个单独的MS Word应用程序对象。 你只需要一个。 实际上，复制/粘贴可能会失败，因为您尝试从一个Word应用程序复制到另一个Word应用程序中打开的文档。 （相信我，我见过这样奇怪的事情。）我的下面的例子显示了如何通过只打开一个应用程序实例来做到这一点。

Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication()   'more on this function below...

Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")

虽然我不经常为Word编写代码，但我发现有很多不同的方法可以使用不同的对象或属性来获取相同的内容。 这始终是混乱的根源。

基于这个过去对我有用的答案 ，然后我设置源和目标范围来执行“复制”：

Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source

以下是整个模块供参考：

Option Explicit

Sub AddDocs()
    Dim wordWasRunning As Boolean
    wordWasRunning = IsMSWordRunning()

    Dim mswApp As Word.Application
    Set mswApp = AttachToMSWordApplication()

    Dim doc1 As Word.Document
    Dim doc2 As Word.Document
    Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
    Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")

    Dim destination As Word.Range
    Dim source As Word.Range
    Set source = doc1.Content
    Set destination = doc2.Content
    destination.Collapse Direction:=Word.wdCollapseEnd
    destination.FormattedText = source

    doc2.Close SaveChanges:=True
    doc1.Close

    If Not wordWasRunning Then
        mswApp.Quit
    End If
End Sub

这是我在样本中使用的几个函数的承诺说明。 我已经构建了一组库函数，其中一些函数可以帮助我访问其他Office应用程序。 我将这些模块保存为.bas文件（通过使用VBA编辑器中的导出功能）并根据需要导入它们。 因此，如果您想使用它，只需使用纯文本编辑器（不在VBA编辑器中）保存下面的代码，然后将该文件导入到项目中。

建议的文件名是Lib_MSWordSupport.bas ：

Attribute VB_Name = "Lib_MSWordSupport"
Attribute VB_Description = "Variety of support functions operating on MS Word"
Option Explicit

Public Function IsMSWordRunning() As Boolean
Attribute IsMSWordRunning.VB_Description = "quick check to see if an instance of MS Word is running"
    '--- quick check to see if an instance of MS Word is running
    Dim msApp As Object
    On Error Resume Next
    Set msApp = GetObject(, "Word.Application")
    If Err > 0 Then
        '--- not running
        IsMSWordRunning = False
    Else
        '--- running
        IsMSWordRunning = True
    End If
End Function

Public Function AttachToMSWordApplication() As Word.Application
Attribute AttachToMSWordApplication.VB_Description = "finds an existing and running instance of MS Word, or starts the application if one is not already running"
    '--- finds an existing and running instance of MS Word, or starts
    '    the application if one is not already running
    Dim msApp As Word.Application
    On Error Resume Next
    Set msApp = GetObject(, "Word.Application")
    If Err > 0 Then
        '--- we have to start one
        '    an exception will be raised if the application is not installed
        Set msApp = CreateObject("Word.Application")
    End If
    Set AttachToMSWordApplication = msApp
End Function