John it's very similar logic to the last post. You can trial this (it's still set up for multi-files)...
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)
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