如何使用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