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

Question

Goal for my project:

I want to be able to copy the contents of one document and append that selection to the end of another document.

What it does ... (this is just background info so you understand why I am trying to do this):

I am trying to dynamically produce a document which quotes a variety of information regarding different parts and materials involved for a product.

The document itself has a consistent format which I have broken down and separated into two documents. The first contains a bunch of data that needs to be entered manually, and is where I want to append all additional content. The second contains roughly a dozen custom fields which are updated from an excel spreadsheet in VBA. For a single part and as a single doc this works as I want it (my base case). However my issue is when there are multiple parts for a project.

The Problem:

For multiple parts I have to store information in an array which changes in size dynamically as each additional part is added. When someone has added all the necessary parts they can select a button called "Create Quote".

Create quote runs a procedure which creates/opens separate copies of the two template documents mentioned above (saved on my computer). It then iterates through the array of parts and updates all the custom field in the 2nd document (no problems). Now I just need the contents of the 2nd document appended to the end of the first which is my problem.

What I want:

Ideally, my procedure will continue to iterate through every part in the array - updating custom fields, copy then paste the updated text, repeat... Until every part is included in the newly generated quote.

What I Tried - this code can be found in my generate quote procedure

I have tried many of the examples and suggestions provided by people who had similar question, but I don't know if its because I am operating from an excel doc, but many of their solution have not worked for me.

This is my most recent attempt and occurs after each iteration of the for loop

        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

QUOTE PROCEDURE - I am only including a handful of the fields I am updating because its not necessary to show them all

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

I apologize this was so long winded. Let me know if there is anything confusing or you may want clarified. I think I included everything though.

Answer 1

I think you're close, so here are a couple of comments and an example.

First of all, you're opening two separate MS Word Application objects. You only need one. In fact, it's possible that the copy/paste is failing because you're trying to copy from one Word app to a document opened in the other. (Trust me, I've seen weird things like this.) My example below shows how to do this by only opening a single application instance.

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")

While I don't often write code for Word, I've found that there are so many different ways to get at the same content using different objects or properties. This is always a source of confusion.

Based on this answer , which has worked well for me in the past, I then set up the source and destination ranges to perform the "copy":

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

Here is the whole module for reference:

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

Here's the promised note on a couple functions I use in the sample. I've built up a set of library functions, several of which help me access other Office applications. I save these modules as .bas files (by using the Export function in the VBA Editor) and import them as needed. So if you'd like to use it, just save the code below in using a plain text editor (NOT in the VBA Editor!), then import that file into your project.

Suggested filename is 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