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

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---

--
RyGuy

ryguy7272
Fri Oct 12 12:02:03 PDT 2007

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





--
RyGuy


"ryguy7272" wrote:

> 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---
>
> --
> RyGuy