有没有办法使用excel vba打开word文档，复制word表，并将其粘贴到另一个word文档

Question

I am trying to use a reference table in excel that contains word document filenames and headings to open the referenced document, find the referenced heading, and then copy the heading (with content) and paste it into another word document.

The word documents normally contain three headings. Within each heading, there is normally 5 paragraphs. In the second paragraph of each heading, there is normally a picture (enhanced metafile). My current code, although ugly, seems to do the job. For some of the word documents, however, the second paragraph contains either a 1x3 word table or a 2x3 word table. There is a title in the first row, a picture (enhanced metafile) in the second row, and source notes in the third row. For the 2x3 tables, the second column contains the same type of information as the first column.

I have made some feeble attempts at using .Selection and table objects, but my brain doesn't really understand how to use them. I have now been stumped for several days and need some help.

Since I'm new to VBA, I copied in the entire code. My apologies for that, but I didn't want to leave out anything relevant.

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

Ideally, I would like to be able to search and find a specific heading, select that heading and its contents (however many paragraphs and pictures it might contain), copy it, and then paste it at the end of another word document.

However, when my program runs into one of these tables, I get a Run-time error '4605' - Application-defined or object-defined error.

Answer 1

Assuming your 'heading' employs a Word heading Style, you could use code like:

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

Note: You should use a true Word template (ie a dotx file) as a template, not a document.