有沒有辦法使用excel vba打開word文檔，復制word表，並將其粘貼到另一個word文檔

Question

我試圖在excel中使用包含word文檔文件名和標題的引用表來打開引用的文檔，找到引用的標題，然后復制標題（包含內容）並將其粘貼到另一個word文檔中。

單詞文檔通常包含三個標題。 在每個標題中，通常有5個段落。 在每個標題的第二段中，通常有一張圖片（增強型圖元文件）。 我現在的代碼，雖然很難看，但似乎可以完成這項工作。 但是，對於某些word文檔，第二段包含1x3字表或2x3字表。 第一行中有標題，第二行有圖片（增強型圖元文件），第三行有源備注。 對於2x3表，第二列包含與第一列相同類型的信息。

我在使用.Selection和table對象時做了一些微弱的嘗試，但是我的大腦並不真正理解如何使用它們。 我已經被困了好幾天了，需要一些幫助。

由於我是VBA的新手，因此我復制了整個代碼。 我為此道歉，但我不想遺漏任何相關的內容。

Option Explicit

Private Sub CommandButton1_Click()

Dim WordApp As Object
Dim GEB As Object
Dim RoundUp As Object
Dim myrange As Object
Dim forum As String
Dim column As String
Dim GEBIssue As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim parg As Integer

'References a drop down box that contains either G7 Economic Observer or G20 Economic Roundup
forum = ThisWorkbook.Sheets("4 - Add entries to roundup").Cells(24, "A").Value
'Column B contains an X if the country is part of the G7 and column C contains an X if the country is part of the G20
If forum = "G7 Economic Observer" Then column = "B" Else column = "C"
Set WordApp = CreateObject("word.application")
Set RoundUp = WordApp.documents.Open("\\ecnoffice05\ilab\ZZ OELR\2. OELR Research\6. Global Economic Briefing\" & forum & " template.docx")

'Rows 2 to 21 contain information on each of the G7 and G20 countries
For i = 2 To 21
  'Columns 4,6,8 contain the name of the word document and columns 5,7,9 contain the name of the word document heading that needs to be copied
  'Issue, columns 8 and 9 pertain to trade entries that contain either a 1x3 or 2x3 table which doesn't seem to copy
  For l = 4 To 8 Step 2
    If ThisWorkbook.Sheets("4 - Add entries to roundup").Cells(i, column).Value = "X" Then
        If IsError(ThisWorkbook.Sheets("4 - Add entries to roundup").Cells(i, l).Value) = False Then
        GEBIssue = ThisWorkbook.Sheets("4 - Add entries to roundup").Cells(i, l).Value
        Set GEB = WordApp.documents.Open("O:\ZZ OELR\2. OELR Research\6. Global Economic Briefing\Final Briefings Distributed\" & GEBIssue & ".docx")
            parg = GEB.Paragraphs.Count
                For j = 1 To parg
                    If GEB.Paragraphs(j).Range.Text = ThisWorkbook.Sheets("4 - Add entries to roundup").Cells(i, l + 1).Value Then
                    'Rudimentary way to copy/paste the heading and content.  Ideally, I'd like to simply select the heading plus content and copy/paste as one unit
                    For k = 0 To 5
                        GEB.Paragraphs(j + k).Range.Copy
                        'Locates the end of the document so the copied content can be pasted at end
                        Set myrange = RoundUp.Range(Start:=RoundUp.Content.End - 1, End:=RoundUp.Content.End - 1)
                        myrange.Paste
                    Next k
                    End If
                Next j
                GEB.Close (False)
        End If
    End If
  Next l
Next i
RoundUp.SaveAs ("\\ecnoffice05\ilab\ZZ OELR\2. OELR Research\6. Global Economic Briefing\" & forum & " draft 1.docx")
RoundUp.Close (True)
WordApp.Quit

End Sub

理想情況下，我希望能夠搜索並找到特定標題，選擇該標題及其內容（無論其中可能包含多個段落和圖片），復制它，然后將其粘貼到另一個word文檔的末尾。

但是，當我的程序運行到其中一個表時，我得到一個運行時錯誤'4605' - 應用程序定義或對象定義的錯誤。

Answer 1

假設您的“標題”采用Word標題樣式，您可以使用以下代碼：

Set WordApp = CreateObject("word.application")
Set RoundUp = WordApp.Documents.Add("\\ecnoffice05\ilab\ZZ OELR\2. OELR Research\6. Global Economic Briefing\" & forum & " template.docx")
'Rows 2 to 21 contain information on each of the G7 and G20 countries
With ThisWorkbook.Sheets("4 - Add entries to roundup")
  For i = 2 To 21
    'Columns 4,6,8 contain the name of the word document and columns 5,7,9 contain the name of the word document heading that needs to be copied
    'Issue, columns 8 and 9 pertain to trade entries that contain either a 1x3 or 2x3 table which doesn't seem to copy
    For l = 4 To 8 Step 2
      If .Cells(i, column).Value = "X" Then
        If IsError(.Cells(i, l).Value) = False Then
          GEBIssue = .Cells(i, l).Value
          Set GEB = WordApp.Documents.Open("O:\ZZ OELR\2. OELR Research\6. Global Economic Briefing\Final Briefings Distributed\" & GEBIssue & ".docx")
          With GEB
            With .Range
              With .Find
                .ClearFormatting
                .Text = ThisWorkbook.Sheets("4 - Add entries to roundup").Cells(i, l + 1).Value
                .Execute
              End With
              If .Find.Found = True Then
                Set myrange = .Duplicate
                Set myrange = myrange.GoTo(What:=-1, Name:="\HeadingLevel") ' -1 = wdGoToBookmark
                RoundUp.Characters.Last.FormattedText = myrange.FormattedText
              End If
            End With
            .Close False
          End With
        End If
      End If
    Next l
  Next i
End With
RoundUp.SaveAs ("\\ecnoffice05\ilab\ZZ OELR\2. OELR Research\6. Global Economic Briefing\" & forum & " draft 1.docx")
RoundUp.Close False
WordApp.Quit

注意：您應該使用真正的Word模板（即dotx文件）作為模板，而不是文檔。