To find word in Microsoft Word Table and copy Offsets to Excel Cells

[Dave]

U can trial this. Change the file address to suit. Dave

Option Explicit
Sub XLWordTable()
Dim WrdApp As Object, Cnt As Integer, FileStr As String
Dim WrdDoc As Object, TblCell As Variant, SearchWord As String
Dim FSO As Object, FolDir As Object, FileNm As Object
'SearchWord is case sensitive
SearchWord = "Fruits"
'On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False
'Set FSO = CreateObject("scripting.filesystemobject")
'change directory to suit
'Set FolDir = FSO.GetFolder("D:\testfolder")
'loop files
'For Each FileNm In FolDir.Files
    'If FileNm.Name Like "*" & ".docx" Then
        'FileStr = CStr(FileNm)
        'change address to suit
        FileStr = "D:\testfolder\tabletest.docx"
        Set WrdDoc = WrdApp.Documents.Open(FileStr)
        'check if table exists
        If WrdApp.ActiveDocument.tables.Count < 1 Then
            GoTo Below
        End If
        'loop tables
        For Cnt = 1 To WrdApp.ActiveDocument.tables.Count
            'loop through table cells
            For Each TblCell In WrdApp.ActiveDocument.tables(Cnt).Range.Cells
                If InStr(TblCell.Range, SearchWord) Then
                    Sheets("sheet1").Range("A" & 1) = WrdApp.ActiveDocument.tables(Cnt).Cell(TblCell.RowIndex + 1, TblCell.ColumnIndex)
                    'remove pilcrow
                    Sheets("sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("sheet1").Range("A" & 1))
                    Sheets("sheet1").Range("B" & 1) = WrdApp.ActiveDocument.tables(Cnt).Cell(TblCell.RowIndex + 1, TblCell.ColumnIndex + 1)
                    Sheets("sheet1").Range("B" & 1) = Application.WorksheetFunction.Clean(Sheets("sheet1").Range("B" & 1))
                    'WrdApp.ActiveDocument.Tables(Cnt).Delete
                    GoTo Below
                End If
            Next TblCell
        Next Cnt
        Below:
        'close and save doc
        WrdApp.ActiveDocument.Close savechanges:=True
        Set WrdDoc = Nothing
    'End If
'Next FileNm
'Set FolDir = Nothing
'Set FSO = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
'Set FolDir = Nothing
'Set FSO = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub