Can anyone tell me what is wrong with this code?

holykimura

New Member
Joined
Apr 29, 2012
Messages
24
2 of my tables (1 and 2) copy into word fine, but the rest of the tables do not appear to be using the "Autofitbehaviour" method and are not fitting on the page. Can anyone tell me why this might be?

Code:
Sub ExcelTablesToWord()




'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com




Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim TableArray As Variant
Dim SheetsArray As Variant
Dim BookmarkArray As Variant


'List of Table Names (To Copy)
  TableArray = Array("Table1", "Table2", "Table4", "Table3", "Table5", "Table6", "Table7", "Table8")
  
'List of Word Document Bookmarks (To Paste To)
  BookmarkArray = Array("Text1", "Text2", "Text3", "Text4", "Text5", "Text6")
  SheetsArray = Array("Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7", "Sheet8", "Sheet9")




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












'Set Variable Equal To Destination Word Document
  On Error GoTo WordDocNotFound
    Set WordApp = GetObject(Class:="Word.Application")
    WordApp.Visible = True
    Set myDoc = WordApp.Documents.Open("N:\test2.docx")
  
  On Error GoTo 0
    'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
'Loop Through and Copy/Paste Multiple Excel Tables
  For x = LBound(TableArray) To UBound(TableArray)




    'Copy Table Range from Excel
      Set tbl = ThisWorkbook.Worksheets(SheetsArray(x)).ListObjects(TableArray(x)).Range
      tbl.Copy
    
    'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
      myDoc.Bookmarks(BookmarkArray(x)).Range.PasteExcelTable _
        LinkedToExcel:=True, _
        WordFormatting:=False, _
        RTF:=False
    
    
   Set WordTable = myDoc.Tables(x)
    With Selection
        
         myDoc.Tables(x).Cell(1, 1).Range.Font.Size = 8
         myDoc.Tables(x).Cell(1, 2).Range.Font.Size = 8
         
         
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = False
        .Font.Italic = False
        .Font.Name = "Calibri"
        .Font.Size = "10"
       


    End With
Next x
   'Autofit Table so it fits inside Word Document
      'Set WordTable = myDoc.Tables(x)
       WordTable.AutoFitBehavior (wdAutoFitWindow)
     
 Set SheetsArray = ThisWorkbook.Sheets("Sheet4")


    
    WordApp.Visible = True
    
   With WordApp.ActiveDocument
        .Bookmarks("Text11").Range.Text = SheetsArray.Range("B22").Value
        .Bookmarks("Text12").Range.Text = SheetsArray.Range("B23").Value
        .Bookmarks("Text13").Range.Text = SheetsArray.Range("B24").Value
        .Bookmarks("Text14").Range.Text = SheetsArray.Range("B25").Value
        .Bookmarks("Text15").Range.Text = SheetsArray.Range("B25").Value
        .Bookmarks("Text16").Range.Text = SheetsArray.Range("B25").Value


 End With
      
Set SheetsArrays = ThisWorkbook.Sheets("Sheet5")
      WordApp.Visible = True
    
   With WordApp.ActiveDocument
        .Bookmarks("Text21").Range.Text = SheetsArray.Range("B22").Value
        .Bookmarks("Text22").Range.Text = SheetsArray.Range("B23").Value
        .Bookmarks("Text23").Range.Text = SheetsArray.Range("B25").Value
        .Bookmarks("Text24").Range.Text = SheetsArray.Range("B22").Value
        .Bookmarks("Text25").Range.Text = SheetsArray.Range("B23").Value
        .Bookmarks("Text26").Range.Text = SheetsArray.Range("B25").Value
        
End With
  
'Completion Message
  MsgBox "Copy/Pasting Complete!", vbInformation
  GoTo EndRoutine
  
'ERROR HANDLER
WordDocNotFound:
  MsgBox "Microsoft Word file 'Excel Table Word Report.docx' is not currently open, aborting.", 16


'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True


'Clear The Clipboard
  Application.CutCopyMode = False


End Sub
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Forum statistics

Threads
1,224,823
Messages
6,181,182
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top