Teaching Macro

[ArthurN]

Hi,
I have this teaching macro for foreign language learning, which goes through
the story, selects the words/phrases with the "Inlinevocabulary" style,
replaces them with a numbered gap, takes the words to the end of the story,
assigns "wordstoinsert" style (so that later students could pick a word and
insert it into the story.
But, this script works on a whole story/documents only, now I have projects
where I have several stories in a single document and I would like my macro
to work on a range/single story and insert the selected words at the end of
that range and then go to the second story and do the same thing, etc.
Hope somebody could help me here.
Here's the original macro:
Sub Vocabulary()
'
' AutoExit.MAIN Macro
'
'
Dim rDcm As Range
Dim LCnt As Long
Set rDcm = ActiveDocument.Range
rDcm.InsertAfter vbCrLf
With rDcm.Find
.Style = "InlineVocabulary"
While .Execute
rDcm.Select ' for testing
ActiveDocument.Range.InsertAfter rDcm.Text & vbCrLf
ActiveDocument.Paragraphs.Last.Previous.Range.Style = "WordsToInsert"
Wend
End With
Set rDcm = ActiveDocument.Range
With rDcm.Find
.Style = "InlineVocabulary"
While .Execute
LCnt = LCnt + 1
rDcm.Select ' for testing
rDcm.Text = "(" & CStr(LCnt) & "). _________"
rDcm.Collapse Direction:=wdCollapseEnd
Wend
End With
End Sub
Thank you in advance,
Arthur

 

[Greg Maxey]

ArthurN,

I have some success using the following code and didn't have time to work
out the quirks:

Sub Vocabulary()
Dim rDcm As Range
Dim oRng As Word.Range
Dim LCnt As Long
Dim i As Long
For i = 1 To ActiveDocument.Sections.Count
LCnt = 0
Set rDcm = ActiveDocument.Sections(i).Range
With rDcm.Find
.Style = "InlineVocabulary"
While .Execute
If rDcm.InRange(ActiveDocument.Sections(i).Range) Then
LCnt = LCnt + 1
Set oRng = ActiveDocument.Sections(i).Range
oRng.Collapse wdCollapseEnd
oRng.MoveEnd wdCharacter, -1
oRng.Text = rDcm.Text & vbCr
ActiveDocument.Sections(i).Range.Paragraphs.Last.Previous.Range.Style
= "WordsToInsert"
rDcm.Text = "(" & CStr(LCnt) & "). _________"
rDcm.Collapse Direction:=wdCollapseEnd
End If
Wend
End With
Next i
End Sub

You need to divide your stories into separate sections of the document
(using section breaks). I haven't been able to determine why, but it seems
that while you clearly set the range to specific section the search
continues through all subsequent sections. Section 1 search includes
section 1 and all later sections, Section 2 search includes section 2 and
all later sections. I added the InRange method to resolve this. I have
also found that you must have an empty paragraph before the section break in
all sections including the last section containing a story (i.e., you will
have an empty section at the end of the document.)

Good luck.

 

[ArthurN]

Thank you so much for the script,
Unfortunately, it didn't work for me, well the script does go through each
of the sections/stories, selecting and replacing the words, but it inserts
the list with the words to insert after the last story, not after each story
as I expected.
May be there's something can be done about that,
Thank you,
Arthur

 

[Greg Maxey]

Arthur,

I used Break Section Next Page type breaks. Are you certain that you
included an empty paragraph before the break in each section and ensured
that the last section containing a story was followed by an empty section?

 

[ArthurN]

I guess, I did everything as you told to do. But all the words from all the
stories still get listed after the last story/section, not after each story,
and I don't know why

 

[Greg Maxey]

I am off to work right now, but if you will contact me via the website
address providing your e-mail address I will return the contact and have you
send your document. I could look at it tonight.

 

[Graham Mayor]

If I understand the requirement correctly, the following modified version
should work. It inserts the words after each section break

Sub Vocabulary()
Dim rDcm As Range
Dim oRng As Word.Range
Dim LCnt As Long
Dim i As Long
For i = 1 To ActiveDocument.Sections.Count
LCnt = 0
Set rDcm = ActiveDocument.Sections(i).Range
With rDcm.Find
.Style = "InlineVocabulary"
While .Execute
If rDcm.InRange(ActiveDocument.Sections(i).Range) Then
LCnt = LCnt + 1
Set oRng = ActiveDocument.Sections(i).Range
oRng.Collapse wdCollapseEnd
oRng.MoveEnd wdCharacter, -1
oRng.Text = LCnt & " " & rDcm.Text & vbCr
oRng.InsertBefore "Words To Insert: "
rDcm.Text = "(" & CStr(LCnt) & "). _________"
rDcm.Collapse Direction:=wdCollapseEnd
End If
Wend
End With
Next i
End Sub

--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[ArthurN]

I submited my email on your web site,
Thanks,
Arthur

 

[ArthurN]

This does seem to work, thanks. Now, the only problem that I see still is
that I'll have to insert a section break after each story by hand.
Each story, in fact, begins with a heading 1 element, which has the option
"page break before" active. But, this doesn't work with the script. Is there
another way then to insert a section break before each heading 1.
Regards,
Arthur

 

[Graham Mayor]

Forget adding the section breaks by hand. The following macro will add them
then run a slightly modified version of the earlier macro to insert the
words as before.

Sub AddSections()
Dim oRng As Range
Dim Count As Long
Count = 0
With Selection
.HomeKey wdStory
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Style = "Heading 1"
.Text = ""
.Replacement.Text = "^&"
.Forward = True
While .Execute = True
Count = Count + 1
Set oRng = Selection.Range
oRng.Collapse wdCollapseStart
If Count > 1 Then
oRng.InsertBreak Type:=wdSectionBreakContinuous
End If
Selection.Collapse wdCollapseEnd
Wend
End With
End With
Call Vocabulary
End Sub
Sub Vocabulary()
Dim rDcm As Range
Dim oRng As Word.Range
Dim LCnt As Long
Dim i As Long
For i = 1 To ActiveDocument.Sections.Count
LCnt = 0
Set rDcm = ActiveDocument.Sections(i).Range
With rDcm.Find
.Style = "InlineVocabulary"
While .Execute
If rDcm.InRange(ActiveDocument.Sections(i).Range) Then
LCnt = LCnt + 1
Set oRng = ActiveDocument.Sections(i).Range
oRng.Collapse wdCollapseEnd
oRng.MoveEnd wdCharacter, -1
oRng.Style = "Normal"
oRng.Text = LCnt & " " & rDcm.Text & vbCr
oRng.InsertBefore "Word To Insert: "
rDcm.Text = "(" & CStr(LCnt) & "). _________"
rDcm.Collapse Direction:=wdCollapseEnd
End If
Wend
End With
Next i
End Sub


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP


<>>< ><<> ><<> <>>< ><<> <>>< <>><<>