Попытка скопировать и вставить несколько разделов таблицы в новое слово doc, продолжает вставлять новые таблицы в первую ячейку

Question

Итак, я пытаюсь скопировать и вставить несколько столбцов базы данных Excel в текстовый документ. Каждый раз, когда он завершает «раунд», он удерживает курсор в первой ячейке и поэтому портит форматирование. Я пытаюсь сделать курсор прокрутки из предыдущей таблицы, чтобы создать новую таблицу ниже. проблемный код указывается в таблице автозаполнения, поэтому он помещается в документ Word

Я пытался

    Selection.MoveDown Unit:=wdLine, Count:=54

но выдает ошибку

Вот мой полный код:

Sub ReportGen()

'ROUND 1

Dim myValue As Variant
Dim atbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim aWordTable As Word.Table

'Define whos info you need
myValue = InputBox("Who are you meeting with?")

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
  Sheets("Stage Gate (Open)").Select
  ActiveSheet.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
  Set atbl = ThisWorkbook.Worksheets("Stage Gate (Open)").Range("C6:C10,a6:a10,b6:b10,e6:e10")


'Create an Instance of MS Word
  On Error Resume Next

    'Is MS Word already opened?
      Set WordApp = GetObject(class:="Word.Application")

    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")

    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0

'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate

'Create a New Document
  Set myDoc = WordApp.Documents.Add

'Copy Excel Table Range
  atbl.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False

'Autofit Table so it fits inside Word Document
  Set aWordTable = myDoc.Tables(1)
  aWordTable.AutoFitBehavior (wdAutoFitWindow)
  myDoc.Selection.MoveDown Unit:=wdLine, Count:=54

'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

'ROUND 2


Dim btbl As Excel.Range
Dim WordTable As Word.Table

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
   Sheets("Stage Gate Support (Open)").Select
  ActiveSheet.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
  Set btbl = ThisWorkbook.Worksheets("Stage Gate Support (Open)").Range("C3:C10,a3:a10,b3:b10,e3:e10")


'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate


'Copy Excel Table Range
  btbl.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False

'Autofit Table so it fits inside Word Document
  Set bWordTable = myDoc.Tables(1)
  bWordTable.AutoFitBehavior (wdAutoFitWindow)
  Selection.MoveDown Unit:=wdLine, Count:=54

'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

'ROUND 3


Dim ctbl As Excel.Range
Dim cWordTable As Word.Table

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
   Sheets("Bermondsey (Open)").Select
  ActiveSheet.Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
  Set ctbl = ThisWorkbook.Worksheets("Bermondsey (Open)").Range("C6:C10,a6:a10,b6:b10,e6:e10")

'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate

'Copy Excel Table Range
  ctbl.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False

'Autofit Table so it fits inside Word Document
  Set cWordTable = myDoc.Tables(1)
  cWordTable.AutoFitBehavior (wdAutoFitWindow)
  Selection.MoveDown Unit:=wdLine, Count:=54

EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False


End Sub

Answer 1

Попробуйте следующее. Обратите внимание, что ничего не выбирается, что делает код намного более эффективным. В кодированном виде каждая таблица выводится на своей странице.

Sub ReportGen()
Dim atbl As Range, btbl As Range, As Range
Dim WordApp As Object, myDoc As Object
Dim myValue As Variant

  'Define who's info you need
  myValue = InputBox("Who are you meeting with?")

  'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

  'Create an Instance of MS Word
  On Error Resume Next
  'Is MS Word already opened?
  Set WordApp = GetObject(, "Word.Application")
  'Clear the error between errors
  Err.Clear
  'If MS Word is not already open then open MS Word
  If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
  'Handle if the Word Application is not found
  If Err.Number = 429 Then
    MsgBox "Microsoft Word could not be found, aborting."
    GoTo EndRoutine
  End If
  On Error GoTo 0
  'Make MS Word Visible and Active
  WordApp.Visible = True

  'Set Excel Ranges
  With Sheets("Stage Gate (Open)")
    .Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
    Set atbl = .Range("C6:C10,a6:a10,b6:b10,e6:e10")
    Set btbl = .Range("C3:C10,a3:a10,b3:b10,e3:e10")
  End With
  With Sheets("Bermondsey (Open)")
    .Range("$A$6:$AL$25").AutoFilter Field:=3, Criteria1:=myValue
    Set ctbl = .Range("C6:C10,a6:a10,b6:b10,e6:e10")
  End With

  'Create a New Document
  Set myDoc = WordApp.Documents.Add
  With myDoc
    'Copy Excel Table Range
    atbl.Copy
    'Paste Table into MS Word
    .Range.Characters.Last.PasteExcelTable False, False, False
    'Autofit Table so it fits inside Word Document
    .Tables(1).AutoFitBehavior 2 'wdAutoFitWindow
    .Range.InsertAfter Chr(12)
    'Copy Excel Table Range
    btbl.Copy
    'Paste Table into MS Word
    .Range.Characters.Last.PasteExcelTable False, False, False
    'Autofit Table so it fits inside Word Document
    .Tables(2).AutoFitBehavior 2 'wdAutoFitWindow
    .Range.InsertAfter Chr(12)
    ctbl.Copy
    'Paste Table into MS Word
    .Range.Characters.Last.PasteExcelTable False, False, False
    'Autofit Table so it fits inside Word Document
    .Tables(3).AutoFitBehavior 2 'wdAutoFitWindow
  End With

  Set atbl = Nothing: Set btbl = Nothing: Set ctbl = Nothing
  Set myDoc = Nothing: Set WordApp = Nothing

EndRoutine:
  'Clear The Clipboard
  Application.CutCopyMode = False
  'Optimize Code
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub