Question

我正在玩这个代码片段，我在SO上找到了它。

Sub Test()
Dim objWord As Object
Dim ws As Worksheet

    Set ws1 = ThisWorkbook.Sheets("Contact Information1")
    Set ws2 = ThisWorkbook.Sheets("Contact Information2")
    'Set ws3 = ThisWorkbook.Sheets("Contact Information3")

    Set objWord = CreateObject("Word.Application")

    objWord.Visible = True

    objWord.Documents.Open "C:\Users\rshuell001\Desktop\Final Report.docx" ' change as required

    With objWord.ActiveDocument
        .Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
        .Bookmarks("BkMark2").Range.Text = ws2.Range("A1:F8").Value
        '.Bookmarks("Report3").Range.Text = ws3.Range("A1:F80").Value
    End With

    Set objWord = Nothing

End Sub

当我看到它时，它是有道理的。当我运行脚本时，我在这一行上收到错误：

。书签（＆＃34; BkMark1＆＃34;）。Range.Text = ws1.Range（＆＃34; A1：F24＆＃34;）。值

错误消息是：运行类型错误13 类型不匹配

1）我不确定＆＃39;。书签（＆＃34; BkMark1＆＃34;）。Range.Text＆＃39;会做我想做的。我认为它更像是标准的复制/粘贴 2）我想确保表格适合Word文档，所以我需要类似下面这一行的东西，让它做我想做的事。

wd.Tables(1).AutoFitBehavior wdAutoFitWindow

关于如何使这项工作的任何想法？

谢谢！

Answer 1

我想出了下面的脚本。它做我想做的事。

Sub Export_Table_Word()

    'Name of the existing Word doc.
    'Const stWordReport As String = "Final Report.docx"

    'Word objects.
    Dim WDApp As Word.Application
    Dim WDDoc As Word.Document
    Dim wdbmRange1 As Word.Range

    'Excel objects.
    Dim wbBook As Workbook
    Dim wsSheet1 As Worksheet
    Dim rnReport1 As Range

    'Initialize the Excel objects.
    Set wbBook = ThisWorkbook
    Set WDApp = New Word.Application
    'Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
    Set WDDoc = WDApp.Documents.Open("C:\Users\rshuell001\Desktop\Final Report.docx")

        'Delete old fields and prepare to replace with new
        Dim doc As Document
        Dim fld As Field
        Set doc = WDDoc
        For Each fld In doc.Fields
          fld.Select
          If fld.Type = 88 Then
            fld.Delete
          End If
        Next

    Set wsSheet = wbBook.Worksheets("Contact Information1")
    Set rnReport = wsSheet.Range("BkMark1")
    Set wdbmRange = WDDoc.Bookmarks("BkMark1").Range

    'Turn off screen updating.
    Application.ScreenUpdating = False
    'Copy the report to the clipboard.
    rnReport.Copy
    'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
    With wdbmRange
        .Select
        .Paste
    End With
    WDDoc.Tables(1).AutoFitBehavior wdAutoFitWindow


    Set wsSheet = wbBook.Worksheets("Contact Information2")
    Set rnReport = wsSheet.Range("BkMark2")
    Set wdbmRange = WDDoc.Bookmarks("BkMark2").Range
    Application.ScreenUpdating = False
    rnReport.Copy
    With wdbmRange
        .Select
        .Paste
    End With
    WDDoc.Tables(2).AutoFitBehavior wdAutoFitWindow


    Set wsSheet = wbBook.Worksheets("Contact Information3")
    Set rnReport = wsSheet.Range("BkMark3")
    Set wdbmRange = WDDoc.Bookmarks("BkMark3").Range
    Application.ScreenUpdating = False
    rnReport.Copy
    With wdbmRange
        .Select
        .Paste
    End With
    WDDoc.Tables(3).AutoFitBehavior wdAutoFitWindow


    'Save and close the Word doc.
    With WDDoc
        .Save
        .Close
    End With

    'Quit Word.
    WDApp.Quit

    'Null out your variables.
    Set fld = Nothing
    Set doc = Nothing
    Set wdbmRange = Nothing
    Set WDDoc = Nothing
    Set WDApp = Nothing

    'Clear out the clipboard, and turn screen updating back on.
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

    MsgBox "The report has successfully been " & vbNewLine & _
           "transferred to " & stWordReport, vbInformation

End Sub

尝试将Excel中多个范围的数据复制到MS Word

1 个答案: