Summarising a text file

[MAB]

I'm trying to copy and paste 3 lines of text from one document to another
every time I find the word 'location' in a large (800 page) text file.
Code below works for the first 2 occurences (out of a possible 130+) then
stops.

' assumes original .txt file has been copied to clipboard before macro is run

Dim iPgs As Integer
' create source word doc
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(3.17)
.BottomMargin = CentimetersToPoints(3.17)
.LeftMargin = CentimetersToPoints(2.54)
.RightMargin = CentimetersToPoints(2.54)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.25)
.FooterDistance = CentimetersToPoints(1.25)
.PageWidth = CentimetersToPoints(29.7)
.PageHeight = CentimetersToPoints(21)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.GutterPos = wdGutterPosLeft
End With
With Options
.CheckSpellingAsYouType = False
.CheckGrammarAsYouType = False
.SuggestSpellingCorrections = False
.SuggestFromMainDictionaryOnly = False
.CheckGrammarWithSpelling = False
.ShowReadabilityStatistics = False
.IgnoreUppercase = False
.IgnoreMixedDigits = True
.IgnoreInternetAndFileAddresses = True
.AllowCombinedAuxiliaryForms = True
.EnableMisusedWordsDictionary = True
.AllowCompoundNounProcessing = True
.UseGermanSpellingReform = True
End With
Selection.Font.Name = "LinePrinter"
Selection.Font.Size = 8.5

' paste .txt file into word source doc and get rid of blank first page

Selection.Paste
Selection.HomeKey Unit:=wdStory
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1

' create target word doc

Documents.Add DocumentType:=wdNewBlankDocument
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(3.17)
.BottomMargin = CentimetersToPoints(3.17)
.LeftMargin = CentimetersToPoints(2.54)
.RightMargin = CentimetersToPoints(2.54)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.25)
.FooterDistance = CentimetersToPoints(1.25)
.PageWidth = CentimetersToPoints(29.7)
.PageHeight = CentimetersToPoints(21)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.GutterPos = wdGutterPosLeft
End With
With Options
.CheckSpellingAsYouType = False
.CheckGrammarAsYouType = False
.SuggestSpellingCorrections = False
.SuggestFromMainDictionaryOnly = False
.CheckGrammarWithSpelling = False
.ShowReadabilityStatistics = False
.IgnoreUppercase = False
.IgnoreMixedDigits = True
.IgnoreInternetAndFileAddresses = True
.AllowCombinedAuxiliaryForms = True
.EnableMisusedWordsDictionary = True
.AllowCompoundNounProcessing = True
.UseGermanSpellingReform = True
End With
Selection.Font.Name = "LinePrinter"
Selection.Font.Size = 8.5

' go back to Source doc and copy report header to target doc

Windows(1).Activate
Selection.MoveDown Unit:=wdLine, Count:=15, Extend:=wdExtend
Selection.Copy
Windows(2).Activate
Selection.Paste

' go back to Source doc

Windows(1).Activate
Selection.MoveUp Unit:=wdLine, Count:=1

' Main Loop: Find word "Location", select 3 lines, copy and paste to Target
document


For iPgs = 1 To ActiveDocument.BuiltInDocumentProperties.Item("number of
pages")
Selection.Find.ClearFormatting
With Selection.Find
.Text = "location"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.Copy
Windows(2).Activate
Selection.Paste
Windows(1).Activate
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveDown Unit:=wdLine, Count:=2

Next
End Sub

 

[Helmut Weber]

Hi,
from your code I assume that you are not too familiar with VBA.
The part for creating the 2 docs is not relevant, I'd say.
At least, it'll causes to problems.
Let's start at the situation,
when you have a source doc and a target doc.

Sub Makro3()
Dim DocSource As Document
Dim DocTarget As Document
Dim rngSource As Range
Dim rngTarget As Range
Set DocSource = Documents("d:\test\source.doc")
Set DocTarget = Documents("d:\test\target.doc")
Set rngSource = DocSource.Range
Set rngTarget = DocTarget.Range
ResetSearch
DocSource.Activate
With rngSource.Find
.Text = "location"
While .Execute
rngSource.Select
With Selection
.Bookmarks("\line").Select
.ExtendMode = True
.MoveDown unit:=wdLine, Count:=2
End With
rngTarget.InsertAfter Selection.Range.Text & vbCr
Wend
End With
ResetSearch
End Sub
' ---
Public Sub ResetSearch()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
' plus some more if needed
.Execute
End With
End Sub


The additional insertion of the paragraph mark vbCr
seems to be important, as the selection of three lines
starting with a line that contains "location" may not
end with a paragraph mark. Also the case, that
"location" might be found less then 2 lines away
from the doc's end. Plus some other situations,
you are hopefully not confronted with.

Greetings from Bavaria, Germany

Helmut Weber, MVP
"red.sys" & chr(64) & "t-online.de"
Word XP, Win 98
http://word.mvps.org/

 

[MAB]

Hi Helmut,

You are absolutely correct - this is the first time I've attempted to use it!

I think I understand your code - I will try it out and let you know the
result.

Many thanks for your quick response!

regards

Mike