Giulia11
10-27-2017, 03:49 AM
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! :)
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! :)