Pasting Excel table to Word, Error on past line "Error 4605"

[VikP]

Hi
I'm pretty new to VBA and I am trying to do something new in it, a recipe for disaster.
First off, I am using Excel 2010 and windows 7 64-bit.
I am trying to copy an excel table into a word doc. This table changes sizes depending on user inputs and won't always fit on one page of a word doc. Because of this I have multiple copy and past lines. The program works in break mode, stepping through it, but it errors out when I run it. The line of code causing the error is

objDoc.Selection.PasteExcelTable False, False, True

The error I get is "Run-time error '4605': This method or property is not available because the current selection is at the end of a table row"
I looked online but couldn't find information on this error that seemed to match my problem.

The line of code works in some parts of my code but causes errors in others.
I have tried using

on error goto 
            err.clear
            Resume

which gives an infinite loop as the error doesn't resolve
I have also tried pausing the execution of the program before the line thinking that word needed time to catch up but that didn't do anything.

Here is the table I am working with
Excel 2010

	B	C	D	E	F	G	H	I	J
2	Home Comparison Report
3
4	Loan Details
5	Amortization	5	5	5	5	5	5	5	5
6	Interest Rate	2.95%	2.95%	2.95%	2.95%	2.95%	2.95%	2.95%	2.95%
7	Monthly Payments per Year	12	12	12	12	12	12	12	12
8	Realtor Fees	3.75%	3.75%	3.75%	3.75%	3.75%	3.75%	3.75%	3.75%
9	GST	5.00%	5.00%	5.00%	5.00%	5.00%	5.00%	5.00%	5.00%
10	Down Payment	$22,238.13	$22,238.13	$22,238.13	$22,238.13	$22,238.13	$22,238.13	$22,238.13	$22,238.13
11
12	Address	402 2nd Ave, Beaver Mines	698 Lacombe St, Pincher Creek	717 Schofield St, Pincher Creek	707 Schofield St, Pincher Creek	891 Dundas St, Pincher Creek	16 Castleview Ridge Estates	718 McDougall St, Pincher Creek	1109 Hewetson Ave, Pincher Creek
13	List Price	$425,000.00	$199,900.00	$199,900.00	$254,900.00	$318,900.00	$254,000.00	$179,900.00	$169,900.00
14	Realtor Fees	$15,937.50	$7,496.25	$7,496.25	$9,558.75	$11,958.75	$9,525.00	$6,746.25	$6,371.25
15	Legal Fees	$3,825.00	$1,399.30	$1,199.40	$1,784.30	$2,551.20	$1,778.00	$1,079.40	$1,359.20
16	Total Price	$444,762.50	$208,795.55	$208,595.65	$266,243.05	$333,409.95	$265,303.00	$187,725.65	$177,630.45
17
18	Loan Amount	$444,762.50	$196,997.20	$196,787.31	$257,317.08	$327,842.32	$256,330.03	$174,873.81	$164,273.85
19	Reccuring Loan Payment	$7,981.92	$3,535.41	$3,531.64	$4,617.94	$5,883.62	$4,600.22	$3,138.37	$2,948.14
20	Monthly Portion of Property Tax	$495.83	$166.58	$199.90	$254.90	$345.48	$338.67	$149.92	$169.90
21	Monthly Mortgage Insurance	$798.19	$247.48	$317.85	$369.43	$470.69	$460.02	$219.69	$235.85
22	Total Monthly Mortgage Payment	$9,275.95	$3,949.47	$4,049.39	$5,242.27	$6,699.78	$5,398.91	$3,507.97	$3,353.89
23
24
25	Total Cost of Ownership in 1st Year	$133,549.49	$69,631.74	$70,830.77	$85,145.37	$102,635.48	$87,025.05	$64,333.79	$62,484.78
26	Present Value of all Ownership Costs	$516,867.20	$220,069.24	$225,636.84	$292,105.79	$373,320.00	$300,833.95	$195,468.52	$186,882.79

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Report​

I've included the entire sub with the problem lines noted. Please don't judge me for my poor coding.
I appreciate any help.

Option Explicit

Sub CreateWordDoc1()
'<<<<the microsoft="" word="" object="" library="" must="" be="" selected="" in="" the="" references.="">>>>></the>

Dim objDoc As Object, i As Integer, columnCount As Integer, j As Integer
Dim wrdDoc As Object


****Set objDoc = CreateObject("Word.Application")
******************objDoc.Visible = True
****Set wrdDoc = objDoc.documents.Add
****
****If objDoc.Selection.PageSetup.Orientation = wdOrientPortrait Then
********objDoc.Selection.PageSetup.Orientation = wdOrientLandscape
****Else
********objDoc.Selection.PageSetup.Orientation = wdOrientPortrait
****End If
******************
****objDoc.Selection.TypeText Text:=wsCalculations.Range("B2").Value

********With objDoc
************.Selection.MoveLeft Unit:=wdCharacter, Count:=24, Extend:=wdExtend
************.Selection.MoveRight Unit:=wdCharacter, Count:=1
********End With
********
****objDoc.Selection.TypeParagraph
****objDoc.Selection.TypeText Text:="Loan Details"
****With objDoc
********.Selection.MoveLeft Unit:=wdCharacter, Count:=12, Extend:=wdExtend
********.Selection.MoveRight Unit:=wdCharacter, Count:=1
****End With
****
****objDoc.Selection.TypeParagraph
****
****With wsCalculations
********columnCount = .Range(.Range("B5"), .Range("B5").End(xlToRight)).Columns.Count - 1
********
********j = 1
********If columnCount > 4 Then
************Do While columnCount > 4
****************
****************'Grab the data headings
****************With .Range("B5")
********************Range(.Offset(0), .End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown)).Copy
****************End With
****************
****************objDoc.Selection.PasteExcelTable False, False, True
****************Application.CutCopyMode = False
****************
****************'reposition the cursor
****************With objDoc
********************.Selection.MoveUp Unit:=wdLine, Count:=22
********************.Selection.MoveRight Unit:=wdCharacter, Count:=13
****************End With
****************
****************'this will clear the undo cache in word which will stop these actions from
****************'being reversed by a user
****************wrdDoc.UndoClear
**************
****************With .Range("B5")
********************Range(.Offset(0, j), .Offset(0, j).End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown).Offset(0, 3)).Copy
****************End With
****************
****************Call WaitPeriod
****************'On Error GoTo Paste_Error
****************
'<<<<<<<<< The code errors out on the next line in run mode but it steps through fine in break mode >>>>
****************objDoc.Selection.PasteExcelTable False, False, True
****************
****************Application.CutCopyMode = False
****************
****************'On Error GoTo 0
**************
****************objDoc.Selection.MoveDown Unit:=wdLine, Count:=23
****************objDoc.Selection.InsertBreak Type:=wdPageBreak
****************objDoc.Selection.TypeText Text:="Loan Details"
****************
****************objDoc.Selection.TypeParagraph
****************
****************j = j + 4
****************columnCount = columnCount - 4
****************wrdDoc.UndoClear
************Loop
************
********
********** If columnCount = 1 Then
****************'Grab the rest of the data headings
****************With .Range("B5")
********************Range(.Offset(0), .End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown)).Copy
****************End With
**************
****************objDoc.Selection.PasteExcelTable False, False, True
****************Application.CutCopyMode = False
****************
****************'Format table and reposition the cursor
****************With objDoc
********************.Selection.MoveUp Unit:=wdLine, Count:=22
********************.Selection.MoveRight Unit:=wdCharacter, Count:=1
********************.Selection.MoveUp Unit:=wdLine, Count:=1
********************.Selection.MoveRight Unit:=wdCharacter, Count:=13
****************End With
****************
****************wrdDoc.UndoClear
****************
****************'Grab the rest of the data
****************With .Range("B5")
********************Range(.Offset(0, j), .Offset(0, j).End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown)).Copy
****************End With
****************
************Else
****************'Grab the rest of the data headings
****************With .Range("B5")
********************Range(.Offset(0), .End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown)).Copy
****************End With
**************
****************objDoc.Selection.PasteExcelTable False, False, True
****************Application.CutCopyMode = False
**************
************
****************'reposition the cursor
****************With objDoc
********************.Selection.MoveUp Unit:=wdLine, Count:=22
********************.Selection.MoveRight Unit:=wdCharacter, Count:=13
****************End With
************
****************wrdDoc.UndoClear
****************
****************With .Range("B5")
********************Range(.Offset(0, j), .Offset(0, j).End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown).End(xlToRight)).Copy
****************End With
****************
************End If
************
************Call WaitPeriod
************'On Error GoTo Paste_Error
************
'<<<<<<<<< The code errors out on the next line in run mode but it steps through fine in break mode >>>>
************objDoc.Selection.PasteExcelTable False, False, True
************
************Application.CutCopyMode = False
************'On Error GoTo 0
************
********Else
************With .Range("B5")
****************Range(.Offset(0), .End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown)).Copy
************End With
**********
************objDoc.Selection.PasteExcelTable False, False, True
************Application.CutCopyMode = False
**********
************
************'reposition the cursor
****************With objDoc
********************.Selection.MoveUp Unit:=wdLine, Count:=22
********************.Selection.MoveUp Unit:=wdLine, Count:=1
********************.Selection.MoveRight Unit:=wdCharacter, Count:=13
****************End With
************
************wrdDoc.UndoClear
************
************'Put the comparison details in the Word Doc
************.Range(.Range("B5"), .Range("B5").End(xlDown).Offset(2).End(xlDown).Offset(2).End(xlDown).Offset(3).End(xlDown).End(xlToRight)).Copy

********** Call WaitPeriod
********** 'On Error GoTo Paste_Error
************objDoc.Selection.PasteExcelTable False, False, True
************Application.CutCopyMode = False
************'On Error GoTo 0
************
********End If
****End With
****
****
****On Error GoTo Error_Handler
****'this will handle the case where the user wants to save multiple reports
****'or runs two in a row with out deleteing one
****i = 0
****objDoc.ActiveDocument.SaveAs ThisWorkbook.Path & "/" & "Home Comparison Report.docx"
****
****wrdDoc.UndoClear
****Application.CutCopyMode = False
****
****
****Exit Sub
Error_Handler:
****If Err <> 0 Then
****i = i + 1
********objDoc.ActiveDocument.SaveAs ThisWorkbook.Path & "/" & "Home Comparison Report " & i & ".docx"
********'objDoc.documents.Close
****End If
****
Paste_Error:
****'tried to ignore the error
****'Wait Period
****'Err.Clear
****'Resume

End Sub


Sub WaitPeriod()
**** 'Tried slowing down the execution of the command but the error still happens
****Application.Wait Now + TimeValue("00:00:01")
End Sub


I'm sorry it's so long, but I thought it might help someone to help me.
Thank you in advance

 

[NdNoviceHlp]

Maybe objDoc.Content.InsertAfter.PasteExcelTable False, False, True Or maybe you need to use the With/End With to paste? I think the selection referred to is actually the Word doc selection (you're pasting a table in a table error) not your copying selection. Untested code suggestion. HTH. Dave

 

[VikP]

Hi Dave. Thanks for responding
I tried .Content.InsertAfter.PasteExcelTable False, False, True and got error 438 object doesn't support
I also tried
.Selection.PasteExcelTable False, False, True 'error 4605
.Selection.Paste 'error 4605
.Selection.PasteExcelTable False, False, True 'error 4605
.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
Placement:=wdInLine, DisplayAsIcon:=False 'error 4605

Have I structured something wrong?

 

[NdNoviceHlp]

This will give you some code ideas. It will paste the whole table as a picture in the Word doc. Change the "Test" file address to suit.

Sub SaveXlRangeToWordFile()
    Dim Wdapp2 As Object, ObjPic As Object
   'open file
    On Error GoTo ErFix
    Set Wdapp2 = CreateObject("Word.Application")
    Wdapp2.ChangeFileOpenDirectory "C:\Test" 'change to suit
    Wdapp2.Documents.Open FileName:="Test.doc" 'change to suit
    Wdapp2.ActiveDocument.Content.PasteSpecial DataType:=3 '9  '4
    'pictures in newxl version are converted to inlineshapes
    'takes time to paste and convert
    Application.Wait (Now + TimeValue("0:00:02"))
    For Each ObjPic In Wdapp2.ActiveDocument.InlineShapes
    ObjPic.ConvertToShape
    Next ObjPic
    'name pic
    'Wdapp2.ActiveDocument.Shapes(1).Name = "XLRange"
    Wdapp2.ActiveDocument.Close savechanges:=True
    Wdapp2.Quit
    Set Wdapp2 = Nothing
    Application.CutCopyMode = False
    Exit Sub

ErFix:
    On Error GoTo 0
    MsgBox "Save to file error."
    Set ObjPic = Nothing
    Wdapp2.ActiveDocument.Close savechanges:=False
    Wdapp2.Quit
    Set Wdapp2 = Nothing
    Application.CutCopyMode = False
End Sub

To use it....

Dim Objtargetrange As Range
With Sheets("Sheet1")
    Set Objtargetrange = .Range(.Cells(2, "B"), .Cells(26, "E"))
End With
Objtargetrange.Copy
Call SaveXlRangeToWordFile

HTH. Dave

 

[VikP]

Thanks for the code ideas Dave. I will probably use that in the future.
I was able to find a work around for my problem. Instead of trying to splice the table together in word I ended up doing to on a temporary worksheet and then transferring the completed table over. No more error.

 

[NdNoviceHlp]

Happy to hear that you resolved your problem. Thanks for posting your outcome. You are Welcome. Dave