CODEWITHSUNDEEP
excelvbams-word
Julian F.
Julian F.

Reputation: 1

Attempting to copy and paste multiple sections of a table to new word doc, keeps pasting new tables in first cell

So I am trying to copy and paste multiple columns of an excel database into a word document. Every time it completes a "round" it keeps the cursor in the first cell and therefore messes up the formatting. I am attempting to make the cursor scroll out of the previous table to create a new table below. the problematic code is indicated in 'Autofit Table so it fits inside Word Document

I have tried 

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

But it gives an error

Here is my full code:

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

Upvotes: 0

Views: 86

Answers (1)

macropod
macropod

Reputation: 13505

Try the following. Note that nothing ever gets selected, which makes the code far more efficient. As coded, each table is output on its own page.

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

Upvotes: 1

Related Questions