在Microsoft Word中标题1之后从Microsoft Excel粘贴表

Question

我有一个问题，当我复制将表格从Microsoft Excel粘贴到Microsoft Word时，它会用表格删除整个文档，我想要的是将表格粘贴到标题1下（例如，1。简介，2。提交，3。来源，4。表格）在标题4下。表。并保持其他信息被删除（1,2和3）这些是从Excel粘贴表格的代码。     

 
    Sub ActivateWord()
    Worksheets("France").Range("France_Table").Copy
    'Declare Object variables for the Word application and document.
    Dim WdApp As Object, wddoc As Object
    'Declare a String variable for the example document’s
    'name and folder path.
    Dim strDocName As String
    'On Error statement if Word is not already open.
    On Error Resume Next
    'Activate Word if it is already open.
    Set WdApp = GetObject(, "Word.Application")
    If Err.Number = 429 Then
    Err.Clear
    'Create a Word application if Word is not already open.
    Set WdApp = CreateObject("Word.Application")
    End If
    'Make sure the Word application is visible.
    If sPath = "" Then
    MsgBox "Please Select a Microsoft Word Macro-Enabled Document"
    Exit Sub
    End If
    WdApp.Visible = True
    'Define the strDocName String variable.
    strDocName = sPath
    'Check the directory for the presence of the document
    'name in the folder path.
    'If it is not recognized, inform the user of that
    'fact and exit the macro.
    If Dir(strDocName) = "" Then
        MsgBox "The file " & strDocName & vbCrLf & _
        "was not found in the folder path" & vbCrLf & _
        "sPath", _
        vbExclamation, _
        "Sorry, that document name does not exist."
        Exit Sub
    End If
    'Activate the Word application.
    WdApp.Activate
    'Set the Object variable for the Word document’s full
    'name and folder path.
    Set wddoc = WdApp.Documents(strDocName)
    'If the Word document is not already open, then open it.
    If wddoc Is Nothing Then Set wddoc = WdApp.Documents.Open(strDocName)
    '    The document is open, so activate it.
    wddoc.Activate
    wddoc.Range.Find.Text = "Sources"
    wddoc.Range.Find.Style = "Heading 1"
    wddoc.Range.Paste
    wddoc.Save
    WdApp.Quit
    'Release the system memory that was reserved for the two
    'Object variables.
     Set wddoc = Nothing
     Set WdApp = Nothing
     'wddoc.Close
     Application.CutCopyMode = False
      'MsgBox "Update Complete, Please Find you File at = " & vbCrLf & _
      '"Excel To Word\Excel to Word(Completed)"
       End Sub
       

       Set myRange = wddoc.Content
      'myRange.Find.Execute FindText:=StartWord
      myRange.Find.MatchWholeWord = True
      myRange.Find.Style = "Heading 1"
      WdApp.Selection.GoTo What:=wdGoToHeading,_
      Which:=wdGoToAbsoluteCount:=4
      Set myRange = myRange.Next
      myRange.Paste
      wddoc.Save

我无法将表格粘贴在第4号标题上，因为有2个标题同名，有没有可能的方法呢？像Goto标题4？

Answer 1

更改此内容：

wddoc.Range.Find.Text = "Sources"
wddoc.Range.Find.Style = "Heading 1"
wddoc.Range.Paste

要 已编辑：我必须将其删除为范围，以便它不会被转换为Excel范围。
已添加：设置myRange = myRange.Next

Dim myRange
Set myRange = wddoc.Content
myRange.Find.Execute FindText:="Sources"
myRange.Find.Style = "Heading 1"
Set myRange = myRange.Next
myRange.Paste

Answer 2

您可能需要考虑以下重构：

Option Explicit

Sub CopyExcelTableToWordDoc()
    'Declare Object variables for the Word application and document.
    Dim WdApp As Object, wdDoc As Object
    'Declare a String variable for the example document’s name and folder path.
    Dim strDocName As String
    Dim sPath As String '<--| do you actually need it? isn't "strDocName" the same? if no, remember to initialize it

    'Define the strDocName String variable.
    strDocName = sPath '<--| where has "sPath" been initialized?

    'Check the directory for the presence of the document name in the folder path.
    'If it is not recognized, inform the user of that fact and exit the macro.
    If Dir(strDocName) = "" Then
        MsgBox "The file " & strDocName & vbCrLf & _
        "was not found in the folder path" & vbCrLf & _
        "sPath", _
        vbExclamation, _
        "Sorry, that document name does not exist."
        Exit Sub
    End If

    Set WdApp = GetWord() '<--| get a Word instance (either running or a new one)
    WdApp.Visible = True '<--| make it visible

    Set wdDoc = GetWordDoc(WdApp, strDocName) '<--| get the document instance
    With wdDoc.Content
        With .Find  '<--| set the Find object and execute it on the entire document content
            .ClearFormatting
            .Style = "Heading 1"
            .Execute FindText:="Sources", Format:=True, Forward:=True
        End With
        If .Find.found Then '<--| if Find is successful...
            .Collapse Direction:=1 '<--| ...collapse the selection to the beginning of the found range (1=wdCollapseStart)...
            .Move Unit:=4, Count:=1 '<--| ...move to the beginning of the next paragraph (4=wdParagraph)...
            Worksheets("France").Range("France_Table").Copy '<--| ...copy the table...
            .Paste '<--| ... paste into word document...
            Application.CutCopyMode = False '<--| ... clear excel clipboard...
            wdDoc.Save '<--| ... and finally save word document, since you actually changed it!
        End If
    End With

    WdApp.Quit 'close Word
    'Release the system memory that was reserved for the two Object variables.
     Set wdDoc = Nothing
     Set WdApp = Nothing
     'MsgBox "Update Complete, Please Find you File at = " & vbCrLf & _
     '"Excel To Word\Excel to Word(Completed)"
End Sub

Function GetWord() As Object
    On Error Resume Next
    'Activate Word if it is already open.
    Set GetWord = GetObject(, "Word.Application")
    If GetWord Is Nothing Then
        'Create a Word application if Word is not already open.
        Set GetWord = CreateObject("word.Application")
    End If
End Function

Function GetWordDoc(WdApp As Object, strDocName As String) As Object
    On Error Resume Next
    Set GetWordDoc = WdApp.Documents(strDocName)
    On Error GoTo 0
    'If the Word document is not already open, then open it.
    If GetWordDoc Is Nothing Then Set GetWordDoc = WdApp.Documents.Open(strDocName)
End Function

以上内容：

• 做＆＃34;事情＆＃34;只在需要的时候

  例如

  • 所有Word内容（应用程序和文档设置）仅在通过If Dir(strDocName) = "" Then检查后

  完成

  • excel表复制仅在单词Find()对象成功执行时完成

  • 只有在实际粘贴了excel表时才保存word文档

  • 只有先前已发出相应的Copy()才能进行剪贴板清算

• 要求Word应用程序和文档设置到特定功能，以免混乱主子代码

• 仅在需要和内部函数时限制On Error Resume Next语句，以便不在其他方面隐藏任何其他可能的错误（以及您想知道的）