将数据从 Excel 传输到预先存在的 Word 表格

Question

I am trying to export data from Excel to a pre-existing Word table.

Once the code reaches the For Each wdCell In wdDoc.Tables loop I receive a run-time error

'91' Object variable or With with block variable not set appears.

Is there a way I can get this code to transfer data into 7 columns?

Sub ExportDataWordTable()

Const stWordDocument As String = "C:\Users\jfournier\Desktop\VBA Macro Files\TESTQUOTE.docm"

Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdCell As Word.Cell
Dim i As Long
Dim j As Long
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim vaData As Variant

Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet2")

ReDim vaData(1 To 10, 1 To 5)

With wsSheet
    vaData = .Range("B3:H20")
End With

'Here we instantiate the new object.
Set wdApp = New Word.Application

'Here the target document resides in the same folder as the workbook.
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordDocument)

'Import data to the first table and in the first column of a table in Microsoft Word.
For j = 1 To 5
    i = 0

    For Each wdCell In wdDoc.Tables(2).Columns(j).Cells
        i = i + 1
        wdCell.Range.Text = vaData(i, j)
    Next wdCell

Next j

'Save and close the document.
With wdDoc
    .Save
    .Close
End With

'Close the hidden instance of Microsoft Word.
wdApp.Quit

'Release the external variables from the memory
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "The data has been transferred to Test.doc", vbInformation

End Sub

Answer 1

Here's a different approach for you to try:

Sub ExportDataWordTable()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Const stWordDocument As String = "\TESTQUOTE.docm"
Dim xlWkBk As Workbook, xlWkSht As Worksheet
Set xlWkBk = ThisWorkbook: Set xlWkSht = xlWkBk.Worksheets("Sheet2")

'Here the target document resides in the same folder as the workbook.
Set wdDoc = wdApp.Documents.Open(Filename:=xlWkBk.Path & stWordDocument, AddToRecentFiles:=False)

'Copy the used range
With xlWkSht
  .Range("B3:H" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).Copy
End With

With wdDoc
  'Paste the copied content to the end of the table
  .Tables(2).Range.Characters.Last.PasteAppendTable

  'Save and close the document.
  .Close True
End With

'Close our instance of Microsoft Word.
wdApp.Quit

'Clear the clipboard
Application.CutCopyMode = False

'Release the external variables from the memory
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlWkSht = Nothing: Set xlWkBk = Nothing

MsgBox "The data has been transferred to Test.doc", vbInformation
End Sub

Note: Since you have varying numbers of rows to copy, the code above assumes the usedrange determines the number of rows to be copied. With this approach, your Word table need only have its header row(s).

Answer 2

I have observed following points in your code for correction.

You are setting the full path of your your file TESTQUOTE.docm

Const stWordDocument As String = "C:\Users\jfournier\Desktop\VBA Macro Files\TESTQUOTE.docm"

Later on You are setting path that the target document resides in the same folder as the workbook.

Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordDocument)

This will give conflict in path string. You should mention only.

Const stWordDocument As String = "TESTQUOTE.docm"

You want code to transfer data into 7 columns. You have taken range as B3:H20 But you have set variant vaData to 5 columns only.

 ReDim vaData(1 To 10, 1 To 5)

Also you are looping for 5 columns only.

'Import data to the first table and in the first column of a table in Microsoft Word.
For j = 1 To 5

Thse two lines need to be changed to :-

ReDim vaData(1 To 10, 1 To 7)

For j = 1 To 7

Other points to ensure are:-

1. You have set Reference to Microsoft Word Object Library corresponding to your version of Excel. I have Excel 2016 so I have set reference to Microsoft Word 16.0 Object Library.
2. Your Word file should pre exist in the same directory where you have stored your ThisWorkbook Macro file. I have Worked with Macro in Excel Macro file and not in Word VBA editor.
3. Your TESTQUOTE word document should have correct Table structure Corresponding to range B3:H20 that is 18 rows and 7 columns. It should be in closed condition when you run VBA Program from Excel File.

Finally your corrected code as follows.

 Sub ExportDataWordTable()

    Const stWordDocument As String = "TESTQUOTE.docm"

    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdCell As Word.Cell
    Dim i As Long
    Dim j As Long
    Dim wbBook As Workbook
    Dim wsSheet As Worksheet
    Dim vaData As Variant

    Set wbBook = ThisWorkbook
    Set wsSheet = wbBook.Worksheets("Sheet2")

    ReDim vaData(1 To 10, 1 To 7)

    With wsSheet
        vaData = .Range("B3:H20")
    End With

    'Here we instantiate the new object.
    Set wdApp = New Word.Application

    'Here the target document resides in the same folder as the workbook.
    Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordDocument)

    'Import data to the first table and in the first column of a table in Microsoft Word.
    For j = 1 To 7
    i = 0

    For Each wdCell In wdDoc.Tables(1).Columns(j).Cells
        i = i + 1
        wdCell.Range.Text = vaData(i, j)
        Next wdCell

    Next j

    'Save and close the document.
    With wdDoc
    .Save
    .Close
    End With

    'Close the hidden instance of Microsoft Word.
    wdApp.Quit

    'Release the external variables from the memory
    Set wdDoc = Nothing
    Set wdApp = Nothing
    MsgBox "The data has been transferred to TESTQUOTE.docm", vbInformation

End Sub

I have tested this program on sample data and I am appending the snapshot of Excel sample data and results obtained on Word document.

Answer 3

[SOLVED]

Err 4605 – "This method or property is not available because the clipboard is empty or not valid"

ErrResume:
    DoEvents
    Range("B3:H99").Copy

    On Error GoTo ErrPaste
        wdDoc.Tables(2).Range.Characters.Last.PasteAppendTable
        Application.CutCopyMode = False
    On Error GoTo 0

ErrPaste:
  'Clipboard is empty or not valid.
    If Err.Number = 4605 Then
        DoEvents
        Resume ErrResume
    End If