Find Keyword, Copy Table, and Place in New Document (almost workin

[ryguy7272]

I am working with the code below to find all files in a directory, with a
certain name, open each, find a keyword, and copy/paste (at append) a table
that contains this keyword, to a summary document. This almost works, but
not quite. I am looking for the text “Additional Information†in one or many
tables, in each document in a certain folder on out firm’s network drive. I
can import all docs in the folder, but not just the tables that contain the
text “Additional Informationâ€. What am I doing wrong? I believe the problem
occurs between the two lines marked '************

My code is below:
Sub Append()

Dim i As Long

Application.ScreenUpdating = False
Documents.Add
With Application.FileSearch
..LookIn = "F:\"
..SearchSubFolders = False
..FileName = "*Summary*.doc"
..Execute
For i = 1 To .FoundFiles.Count
If InStr(.FoundFiles(i), "~") = 0 Then

'*************************************
Selection.Find.ClearFormatting
With Selection.Find
..Text = "Additional Information"
..Replacement.Text = ""
..Forward = True
..Wrap = wdFindContinue
..Format = False
..MatchCase = False
..MatchWholeWord = False
..MatchWildcards = False
..MatchSoundsLike = False
..MatchAllWordForms = False
End With
Selection.Find.Execute
'*************************************

Selection.InsertFile FileName:=(.FoundFiles(i)), _
ConfirmConversions:=False, Link:=False, Attachment:=False
Selection.InsertBreak Type:=wdPageBreak
End If
Next i
End With
End Sub


Regards,
Ryan---

 

[ryguy7272]

GOT IT!!!
Sub Append()

Dim i As Long
Dim oDoc As Document
Dim NumTbl As Integer
Dim A As Integer

Application.ScreenUpdating = False
Documents.Add
With Application.FileSearch
..LookIn = "F:\"
..SearchSubFolders = False
..FileName = "*Report*.doc"
..Execute
For i = 1 To .FoundFiles.Count
If InStr(.FoundFiles(i), "~") = 0 Then


Selection.InsertFile FileName:=(.FoundFiles(i)), _
ConfirmConversions:=False, Link:=False, Attachment:=False


Set oDoc = ActiveDocument
NumTbl = oDoc.Tables.Count


For A = NumTbl To 1 Step -1

If InStr(1, oDoc.Tables(A).Range.Text, "Report", vbTextCompare) > 0 Then
Selection.InsertBreak Type:=wdPageBreak

Else
oDoc.Tables(A).Delete
End If
Next A


Selection.InsertBreak Type:=wdPageBreak
End If
Next i
End With
End Sub