在Word中標題1之后從Microsoft Excel粘貼表

Question

我有一個問題，當我將表格從Microsoft Excel復制粘貼到Microsoft Word時，它會擦除​​帶有表格的整個文檔，我想要的是將表格粘貼到標題1下（例如1. Introduction，2。在標題4.表下提交3.來源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

以上內容：

• 僅在需要時才做“事情”

  例如

  • 只有在通過If Dir(strDocName) = "" Then之后，所有Word內容（應用程序和文檔設置）才完成， If Dir(strDocName) = "" Then檢查

  • 僅當成功執行單詞Find()對象時才完成excel表復制

  • 僅當已實際粘貼excel表時才保存Word文檔

  • 僅在先前已發出相應的Copy()清除剪貼板

• 要求Word應用程序和文檔設置具有特定功能，以免使主子代碼混亂

• 僅在需要時且在函數內部限制On Error Resume Next語句，以免在函數外部隱藏任何其他可能的錯誤（以及您想知道的錯誤）