excelvbams-wordvba7vba6

Copy List of Tables from Excel to Word


I am trying to copy list of Tables in a single sheet to Word.

The tables are pasted in the beginning of document.

Is there any way to paste at bookmarks?
Also can the code contain manner to format from VBA itself?

Sub ListObjectToWord_Multi()

    'Declare Word Variables
    Dim WrdApp As Object
    Dim WrdDoc As Word.Document
    Dim WrdTbl As Word.Table
    
    'Declare Excel Variables
    Dim ExcLisObj As ListObject
    Dim WrkSht As Worksheet
    
    'Create a new instance of word
    Set WrdApp = CreateObject("Word.Application")
    
    With WrdApp
        .Visible = True
        .Documents.Open Range("F3").Value
        .Activate
    
       'Loop through all the Worksheets in Active Workbook
        For Each WrkSht In ThisWorkbook.Worksheets
        
            'Loop thorugh all objects on the active sheet
            For Each ExcLisObj In WrkSht.ListObjects
        
                'Copy the List Object
                ExcLisObj.Range.Copy
        
                'Pause the excel Application for few seconds
                Application.Wait Now() + #12:00:03 AM#
        
                'Go to New Page
                WrdApp.Selection.GoTo What:=wdGoToBookmarks, Which:=wdGoTo
        
                'Paste List Objects into the word document
                With WrdApp.Selection
                    .PasteExcelTable LinkedToExcel:=True, WordFormatting:=True, RTF:=True
                End With
        
                'Clear my Clipboard
                Application.CutCopyMode = False
        
            Next
    
            'Go to First Page
            WrdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst
    
        Next
    
    End With
    
End Sub

Solution

  • Please try.

    Option Explicit
    Sub ListObjectToWord_Multi()
        'Declare Word Variables
        Dim WrdApp As Object
        Dim WrdDoc As Word.Document
        Dim WrdTbl As Word.Table
        'Declare Excel Variables
        Dim ExcLisObj As ListObject
        Dim WrkSht As Worksheet
        Dim i As Long, bmCount As Long
        'Create a new instance of word
        Set WrdApp = CreateObject("Word.Application")
        '    Set WrdApp = GetObject(, "Word.Application")
        With WrdApp
            .Visible = True
            .Documents.Open Range("F3").Value
            Set WrdDoc = .ActiveDocument
            bmCount = WrdDoc.Bookmarks.Count
        End With
        i = 1
        'Loop through all the Worksheets in Active Workbook
        For Each WrkSht In ThisWorkbook.Worksheets
            'Loop thorugh all objects on the active sheet
            For Each ExcLisObj In WrkSht.ListObjects
                If i > bmCount Then
                    MsgBox "The count of bookmarks is less than listbox."
                    Exit Sub
                Else
                    WrdApp.Selection.GoTo What:=wdGoToBookmark, Name:=WrdDoc.Bookmarks(i).Name
                End If
                'Paste List Objects into the word document
                With WrdApp.Selection
                    .Collapse wdCollapseEnd
                    ExcLisObj.Range.Copy
                    'Pause the excel Application for few seconds
                    ' Application.Wait Now() + TimeSerial(0, 0, 1)
                    .PasteExcelTable LinkedToExcel:=True, WordFormatting:=True, RTF:=True
                End With
                'Clear my Clipboard
                Application.CutCopyMode = False
                i = i + 1
            Next
        Next
        'Go to First Page
        WrdApp.Selection.HomeKey Unit:=wdStory
    End Sub