John this seems like it should work. Change the folder directory 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 = "Solo"
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)
'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
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