Excel Macro modification required to pull data from multiple Word docs and to address RUN TIME ERROR CODE '4605'

Question

I already have a Macro in Excel that pulls through data from specific tables, rows and columns in a specified Word doc and returns it to cells in my Excel s/sheet. I need to make 2 alterations to the code but my knowledge is not advanced enough.

1. I need to run this code on multiple Word docs in a specified folder, whether it is .doc or a .docx

2. I need to establish why on some Word docs, the code fails to pull through the data from the Word doc and I get RUN TIME ERROR CODE '4605' 'The method or property is not available because no text is selected'. I tried putting, 'on error resume next', at the start of the module so it keeps on running to the end, in the hope that some text would get pulled through, but still none of the cells in my Excel s/sheet get populated.

Sub ImportFromWord()

On Error Resume Next

  'Activate Word Object Library

  Dim WordDoc As Word.Document

  Set WordApp = CreateObject("word.application") ' Open Word session

  WordApp.Visible = False 'keep word invisible
  Set WordDoc = WordApp.Documents.Open("C:\Users\brendan.ramsey\OneDrive - Ofcom\Objectives\Brendan's Objectives 2022-23\Licence calls\test 2.docx") ' open Word file

  'copy third row of first Word table
  WordDoc.Tables(1).Cell(Row:=1, Column:=3).Range.Copy

  'paste in Excel
  Range("A3").PasteSpecial xlPasteValues
  
  WordDoc.Tables(4).Cell(Row:=3, Column:=6).Range.Copy
  Range("B3").PasteSpecial xlPasteValues
  
  WordDoc.Tables(4).Cell(Row:=3, Column:=3).Range.Copy
  Range("C3").PasteSpecial xlPasteValues
  
  WordDoc.Tables(5).Cell(Row:=2, Column:=5).Range.Copy
  Range("D3").PasteSpecial xlPasteValues
  
  WordDoc.Tables(5).Cell(Row:=2, Column:=7).Range.Copy
  Range("E3").PasteSpecial xlPasteValues
  
  WordDoc.Tables(5).Cell(Row:=2, Column:=2).Range.Copy
  Range("F3").PasteSpecial xlPasteValues



  WordDoc.Close 'close Word doc
  WordApp.Quit ' close Word

End Sub

Answer 1

RUN TIME ERROR CODE '4605' 'The method or property is not available because no text is selected'.

Runtime Code 4605 happens when Microsoft Word fails or crashes whilst it's running. It doesn't necessarily mean that the code was corrupt in some way, but just that it did not work during its run-time. This kind of error will appear as an annoying notification on your screen unless handled and corrected. Here are symptoms, causes and ways to troubleshoot the problem.

As the error message says there is no text selected. To find out what property or method gives the error message I'd recommend breaking the chain of calls in the single line of code by declaring each property or method call on a separate line, so you will know which call fails exactly.

Answer 2

Your code may behave better if you avoid all that copy/paste and transfer the cell contents directly:

Sub ImportFromWord()
    Const FLDR_PATH As String = "C:\Temp\Docs\"
    Dim WordDoc As Word.Document, WordApp As Word.Application
    Dim rw As Range, f
    
    Set rw = ActiveSheet.Rows(3) 'or some other sheet

    f = Dir(FLDR_PATH & "*.doc*") 'check for document
    Do While Len(f) > 0
        
        If WordApp Is Nothing Then 'open word if not already open
            Set WordApp = CreateObject("word.application")
            WordApp.Visible = False
        End If
        
        With WordApp.Documents.Open(FLDR_PATH & f, ReadOnly:=True) ' open Word file
        
            WordCellToExcel .Tables(1).Cell(Row:=1, Column:=3), rw.Cells(1)
            WordCellToExcel .Tables(4).Cell(Row:=3, Column:=6), rw.Cells(2)
            WordCellToExcel .Tables(4).Cell(Row:=3, Column:=3), rw.Cells(3)
            'etc etc
            .Close savechanges:=False
        End With
        
        Set rw = rw.Offset(1) 'next row down
        f = Dir()             'next file, if any
    Loop
    
    If Not WordApp Is Nothing Then WordApp.Quit ' close Word if it was opened

End Sub

'transfer content from a cell in a Word Table to an Excel range
Sub WordCellToExcel(wdCell As Word.Cell, destCell As Range)
    Dim v
    v = wdCell.Range.Text
    destCell.Value = Left(v, Len(v) - 2) 'remove "end of cell" marker
End Sub