Trying to copy data from several ranges in Excel to MS Word

Question

I'm playing around with this code snippet, which I found on 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

When I look at it, it makes sense. When I run the script, I get an error on this line:

.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value

The error message is: Run-type error 13 Type mismatch

1) I'm not sure '.Bookmarks("BkMark1").Range.Text' will do what I want. I think it's more of a standard copy/paste.
2) I want to make sure the table fits in the Word document, so I'm going to need something like the line below, to get it to do what I want.

wd.Tables(1).AutoFitBehavior wdAutoFitWindow

Any ideas on how to make this work?

Thanks!

Answer 1

I came up with the script below. It does what I want.

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