Loop to extract paragraphs that contain a specific word and copy in another document

[Giulia11]

Hello everyone,

I have a range (a part of a chapter), inside a Word file, with this structure:

- Project title: ...
- Country: ...
- Description: ...
- Year: ...
- Status: ...

This structure is repeated many times (one time for every different project).
I should create a function or a cycle that extracts only the parts related to Italy, and copies it in a second Word file. I created a function that finds the line with "ITALY", expands the range 2 paragraphs above and then 5 paragraphs below (in order to include from Project title to Status), copies it and pastes in a new document.


Sub CopyBM()

Documents.Open FileName:="C:\Users\Documents\OriginalFile.docm" 'This is the original file, from which I will extract some parts

Dim Rng As Range, St As Long, Ed As Long
Dim smallRng1 As Range, smallRng2 As Range, smallRngTot As Range

' I create the range (I put bookmarks in the original Word file):
St = ActiveDocument.Bookmarks("startTest1").Start
Ed = ActiveDocument.Bookmarks("endTest1").End
Set Rng = ActiveDocument.Range(Start:=St, End:=Ed)

With Rng.Find

.Text = "(ITALY)" ' the word I am looking for
.Execute
If .Found Then
Rng.Expand Unit:=wdSentence
Rng.Select

Selection.MoveUp Unit:=wdParagraph, Count:=2 'I move the cursor 2 paragraphs above the country line --> Line with the project name
Set smallRng1 = Selection.Range

Selection.MoveDown Unit:=wdParagraph, Count:=5 'I move the cursor 5 paragraphs below the project name line --> Status line
Set smallRng2 = Selection.Range

Set smallRngTot = ActiveDocument.Range(smallRng1.Start, smallRng2.End)
smallRngTot.Copy

Documents.Open FileName:="C:\Users\Documents\Test1.docx" ' This is the new file that I create
Selection.PasteAndFormat (wdPasteDefault)

End If

End With

End Sub



First problem: The code above doesn't work if I look for a word that doesn't exist, e.g. Spain. In this case, instead of copy nothing in the new document, it copies the part related to another country. (My goal is to create documents "country specific", but I don't know a priori which countries are not included, because the file is very long).

Second problem:
I should insert a loop in order to extract all the projects related to Italy (and then all the projects related to France, to UK...).
So I tried to write a loop, but it's an infinite-loop:crying::


Sub CopyBM()

Documents.Open FileName:="C:\Users\Documents\OriginalFile.docm" 'This is the original file, from which I will extract some parts

Dim Rng As Range, St As Long, Ed As Long
Dim smallRng1 As Range, smallRng2 As Range, smallRngTot As Range

' I create the range (I put bookmarks in the original Word file):
St = ActiveDocument.Bookmarks("startTest1").Start
Ed = ActiveDocument.Bookmarks("endTest1").End
Set Rng = ActiveDocument.Range(Start:=St, End:=Ed)

Dim wd As Range
Documents.Open FileName:="C:\Users\Documents\OriginalFile.docm" 'This is the original file, from which I will extract some parts

For Each wd In Rng.Words

With Rng.Find

.Text = "(ITALY)" ' the word I am looking for
.Execute

Rng.Expand Unit:=wdSentence
Rng.Select

Selection.MoveUp Unit:=wdParagraph, Count:=2 'I move the cursor 2 paragraphs above the Prime's country line --> Line with the project name
Set smallRng1 = Selection.Range

Selection.MoveDown Unit:=wdParagraph, Count:=5 'I move the cursor 5 paragraphs below the project name line --> Status line
Set smallRng2 = Selection.Range

Set smallRngTot = ActiveDocument.Range(smallRng1.Start, smallRng2.End)
smallRngTot.Copy


Documents.Open FileName:="C:\Users\Documents\Test1.docx"
' -->This is the new file that I create
Selection.PasteAndFormat (wdPasteDefault)

End With
Rng.MoveStart Unit:=wdParagraph, Count:=6 ' --> This is for trying to move the new range start at the end of the previous little range, so at the end of the status line
Next wd

End Sub



Can anyone suggest a method that might work, please? Thank you! :)

[gmayor]

Without the sample document, this is difficult to test, and you haven't said if there is more than one instance for each country.
The bookmarks appear to be irrelevant and you appear to be pasting into the same document each time, which surely is not what you require for multiple countries?
The following should produce the first instance of each country named in the list and create a new document with the parameters you have mentioned.


Option Explicit
'Graham Mayor - http://www.gmayor.com - Last updated - 27 Oct 2017
Sub CopyBM()
Dim Rng As Range
Dim oDoc As Document
Dim vFindText As Variant
Dim i As Integer

vFindText = Array("ITALY", "FRANCE", "SPAIN", "BELGIUM", "GREECE", "RUSSIA", "KENYA") 'list separated by commas
Documents.Open FileName:="C:\Users\Documents\OriginalFile.docm" 'This is the original file, from which I will extract some parts

For i = LBound(vFindText) To UBound(vFindText)
Set Rng = ActiveDocument.Range
With Rng.Find
Do While .Execute(FindText:=vFindText(i), MatchCase:=True)
Rng.MoveStart wdParagraph, -2
Rng.Start = Rng.Paragraphs(1).Range.Start
Rng.MoveEnd wdParagraph, 5
Rng.End = Rng.Paragraphs.Last.Range.End
Set oDoc = Documents.Add
oDoc.Range.FormattedText = Rng
Exit Do
Loop
End With
Next i
lbl_Exit:
Set oDoc = Nothing
Set Rng = Nothing
Exit Sub
End Sub

[Giulia11]

Thank you for helping! Yes, there is more than one instance for each country, e.g.:

- italian project
- france project
- italian project
- italian project
- english project
- ...

So I should create a loop that extracts all the italian projects and copies them in the new document. Instead it is not necessary to create an array, I can modify each time the name of the country that I want to extract (there are a lot of projects but not a lot of countries :) )

Let me know if you have any idea:)

[gmaxey]

Graham,

Nothing to do. Please excuse the intrusion ;-).

If there are multiple instances of Italian projects, French projects etc. in your source document then Graham's code as modified here may suffice:


Sub CopyBM()
'Graham Mayor - http://www.gmayor.com - Last updated - 27 Oct 2017
'with modifications by Greg Maxey.
Dim oRng As Range, oDocRng As Range
Dim oDocSource As Document, oDoc As Document
Dim vFindText As Variant
Dim lngIndex As Long, lngCount As Long
Dim oCol As Collection
vFindText = Array("ITALY", "FRANCE", "SPAIN", "BELGIUM", "GREECE", "RUSSIA", "KENYA") 'list separated by commas
Set oDocSource = Documents.Open("D:\Test.docm") 'This is the original file, from which I will extract some parts"
'Search for each term.
For lngIndex = LBound(vFindText) To UBound(vFindText)
Set oCol = New Collection
Set oRng = oDocSource.Range
With oRng.Find
Do While .Execute(FindText:=vFindText(lngIndex), MatchCase:=True)
oRng.MoveStart wdParagraph, -2
oRng.Start = oRng.Paragraphs(1).Range.Start
oRng.MoveEnd wdParagraph, 5
oRng.End = oRng.Paragraphs.Last.Range.End
'Add each instance.
oCol.Add oRng.Duplicate, oRng.Duplicate
oRng.Collapse wdCollapseEnd
Loop
End With
'If term found create document.
If oCol.Count > 0 Then
Set oDoc = Documents.Add
For lngCount = 1 To oCol.Count
Set oDocRng = oDoc.Range
oDocRng.Collapse wdCollapseEnd
oDocRng.FormattedText = oCol.Item(lngCount).FormattedText
Next lngCount
End If
Next lngIndex
lbl_Exit:
oDocSource.Close wdDoNotSaveChanges
Set oDoc = Nothing: Set oDocSource = Nothing
Set oRng = Nothing: Set oDocRng = Nothing
Exit Sub
End Sub

[Giulia11]

Thanks a lot to both of you, that's what I was looking for!
One last thing:
this code has to refer only to a small part of my original document, between 2 bookmarks that I've put. (And then I need to add this part of code to another part that refers to other bookmarks, but this is easier because other parts won't be country-specific).
I tried to modify your code like this:



Sub CopyBM()


Dim oDocRng As Range
Dim oDocSource As Document, oDoc As Document
Dim vFindText As Variant
Dim lngIndex As Long, lngCount As Long
Dim oCol As Collection
vFindText = Array("ITALY", "FRANCE", "SPAIN", "BELGIUM", "GREECE", "RUSSIA", "KENYA") 'list separated by commas
Set oDocSource = Documents.Open("C:\Users\Documents\OriginalFile.docm") 'This is the original file, from which I will extract some parts"

' I create my range, where I have to search for "Italy", "France".. (I put bookmarks in the original Word file):
Dim Rng As Range, St As Long, Ed As Long
St = oDocSource.Bookmarks("startTest1").Start ' "startTest1" is the name of the first bookmark in my original Word file
Ed = oDocSource.Bookmarks("endTest1").End ' "endTest1" is the name of the second bookmark in my original Word file
Set Rng = oDocSource.Range(Start:=St, End:=Ed) ' this is the range where I have to do the research. So now I won't use your oRng but I'll use this specific Rng

'Search for each term.
For lngIndex = LBound(vFindText) To UBound(vFindText)
Set oCol = New Collection

With Rng.Find
Do While .Execute(FindText:=vFindText(lngIndex), MatchCase:=True)
Rng.MoveStart wdParagraph, -2
Rng.Start = oDocSource.Bookmarks("startTest1").Start ' --> I modified your range start

Rng.MoveEnd wdParagraph, 5
Rng.End = oDocSource.Bookmarks("endTest1").End ' --> I modified your range end

'Add each instance.
oCol.Add Rng.Duplicate, Rng.Duplicate
Rng.Collapse wdCollapseEnd
Loop
End With
'If term found create document.
If oCol.Count > 0 Then
Set oDoc = Documents.Add
For lngCount = 1 To oCol.Count
Set oDocRng = oDoc.Range
oDocRng.Collapse wdCollapseEnd
oDocRng.FormattedText = oCol.Item(lngCount).FormattedText
Next lngCount
End If
Next lngIndex
lbl_Exit:
oDocSource.Close wdDoNotSaveChanges
Set oDoc = Nothing: Set oDocSource = Nothing
Set Rng = Nothing: Set oDocRng = Nothing
Exit Sub
End Sub



But this error appears: "Run time error 457: This key is already associated with an element of this collection", referred to the line "oCol.Add Rng.Duplicate, Rng.Duplicate'', so I don't know how to proceed.
(I have to indicate the bookmarks because in the original document there are other paragraphs that contain the words "Italy", "France".. but that I don't want to extract).
Thank you again!:)

[macropod]

Another one for the mix:

Sub Demo()
Application.ScreenUpdating = False
Dim DocTgt As Document, i As Long, ArrList() As Variant
Const StrSrc As String = "D:\Test.docm"
ArrList = Array("ITALY", "FRANCE", "SPAIN", "BELGIUM", "GREECE", "RUSSIA", "KENYA") 'list separated by commas
'Search for each term.
For i = LBound(ArrList) To UBound(ArrList)
Set DocTgt = Documents.Add(StrSrc)
With DocTgt
With .Range
.Font.Hidden = True
With .Find
.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Font.Hidden = True
.Format = True
.MatchWildcards = True
.Replacement.ClearFormatting
.Replacement.Font.Hidden = False
.Text = "[!^13]@^13[!^13]@^13[!^13]@" & ArrList(i) & "*^13*^13*^13*^13*^13*^13"
.Replacement.Text = "^&"
.Execute Replace:=wdReplaceAll
End With
.Characters(1).Font.Hidden = .Characters(2).Font.Hidden
With .Find
.Text = ""
.Replacement.Text = ""
.Replacement.ClearFormatting
.Execute Replace:=wdReplaceAll
End With
End With
End With
Next i
Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub

[macropod]

this code has to refer only to a small part of my original document, between 2 bookmarks that I've put
Instead of using two bookmarks, simply apply a single bookmark the whole of the range concerned. Then, with my code, all you'd need to do is change:
With .Range
to:
With .Bookmarks("BkMk").Range
where 'BkMk' is the bookmark's name, and change:
.Wrap = wdFindContinue
to:
.Wrap = wdFindStop