有没有办法使用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文件）作为模板，而不是文档。