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

Question

我的项目目标:

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

它的作用...(这只是背景信息，以便您了解我为什么要这样做):

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

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

问题:

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

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

我想要什么:

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

我尝试过的 - 此代码可以在我的生成报价程序中找到

我尝试了许多有类似问题的人提供的示例和建议，但我不知道是否是因为我是根据 Excel 文档进行操作的，但他们的许多解决方案对我不起作用。

这是我最近的尝试，发生在 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 编写代码，但我发现有很多不同的方法可以使用不同的对象或属性来获取相同的内容。这始终是困惑的根源。

基于this answer ，这在过去对我来说效果很好，然后我设置源和目标范围来执行“复制”:

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

这是关于我在示例中使用的几个函数的 promise 注释。我已经构建了一组库函数，其中一些可以帮助我访问其他 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