Copy multiple tables from selected Excel ranges to Word under each other-CodePudding

The following is an Excel VBA code that aims to copy the selected excel range and paste it into a Word document at the very next paragraph below the current cursor position.

However, there are issues with the code:

1- How to use the word document I set by Set WordDoc = WordApp.Documents("Test.docx") so that I can avoid pasting into another document by mistake?

2- Why do both instances of MoveDown fail when explicitly setting their options to Unit:=wdparagraph, Count:=1, Extend:=wdMove, and get the error

Run-time error '4120': Bad parameter

Sub CopyTableToWord()

Selection.Copy

Dim WordApp As Object
Set WordApp = GetObject(, "Word.Application")
WordApp.Visible = True

Dim WordDoc As Object
Set WordDoc = WordApp.Documents("Test.docx")

' cursor position
WordApp.Selection.Range.Characters.Last.InsertParagraphAfter
WordApp.Selection.MoveDown 'Unit:=wdparagraph, Count:=1, Extend:=wdMove

With WordApp.Selection

  .Range.PasteExcelTable False, False, False
  
  With .Range.Tables(1)
    
    .Range.ParagraphFormat.SpaceBefore = 0
    .Range.ParagraphFormat.SpaceAfter = 0
    .AutoFitBehavior 2 'wdAutoFitWindow
    .Range.Select
    
  End With

    ' move out of the table, then add space after it 
    ' to move the Word cursor to the new position
    ' of the next table to be pasted
    .Collapse wdCollapseEnd
    .Range.InsertParagraphAfter
    .MoveDown 'Unit:=wdParagraph, Count:=1, Extend:=wdMove
    
End With

End Sub

CodePudding user response：

For copying & pasting tables one at a time and with only a single instance of Word running, you could use something like:

Sub PasteAndFormatTableInWord()
Application.ScreenUpdating = False
Dim wdApp As Word.Application, wdDoc As Word.Document
Const StrDocNm As String = "Test.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
With wdApp
  'Check if the document is open.
  For Each wdDoc In .Documents
    If wdDoc.Name = StrDocNm Then Exit For
  Next
  If wdDoc Is Nothing Then
    MsgBox "Your '" & StrDocNm & "' document isn't open." & vbCr & _
      "Please open the document and select the insertion point.", vbExclamation: Exit Sub
  End If
  wdDoc.Activate
  With .Selection
    .Collapse 1 'wdCollapseStart
    With .Range
      .PasteAndFormat 16 'wdFormatOriginalFormatting
      With .Tables(1)
        .AutoFitBehavior 2 'wdAutoFitWindow
        .Cell(1, 1).PreferredWidthType = 3 'wdPreferredWidthPoints
        .Cell(1, 1).PreferredWidth = 75
        .Range.Characters.Last.Next.InsertBefore vbCrLf
      End With
      .Start = .Tables(1).Range.End   1
      .Collapse 0 'wdCollapseEnd
      .Select
    End With
  End With
  wdDoc.Save
End With
Application.ScreenUpdating = False
End Sub