将表格列表从 Excel 复制到 Word

Question

我正在尝试将单张纸中的表格列表复制到 Word。

表格粘贴在文档的开头。

有什么方法可以粘贴到书签吗？
代码还可以包含 VBA 本身的格式化方式吗？

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

Answer 1

请尝试一下。

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