Duplicate and alter text in a Word document using VBA Scripts - vba

Question

I would like to alter a Word document by using a Word VBA script. The Word document consists of bibliographic records. I would like to duplicate the first occurrence of field \TRF of each record and to change its field label (into \OTT). I recorded a VBA Script and it works fine if I position the cursor in front of the first occurrence of \TRF. I would like the VBA Script to repeat the alterations in the entire document but to only alter all first occurrences of \TRF. Recording a VBA Script with keyboard keys (Ctrl+F) plus text didn’t work. And my attempts to add vba code to the VBA Script where not successful.. What is the correct syntax I have to add to my VBA Script?
Original text:
(this example displays one record, the document contains more records)
\PPN 375496173
\TTT Pour un autre regard sur l'art beti / Bienvenu Cyrille Bela
\TRF Cameroon
\TRF Beti
\TRF sculpture
\TRF visual arts
\DAT 15-08-14
\DAV 20140815
\SIG AFRIKA 47231
\ISP text
\END
Text after alteration
\PPN 375496173
\TTT Pour un autre regard sur l'art beti / Bienvenu Cyrille Bela
\TRF Cameroon
\OTT Cameroon
\TRF Beti
\TRF sculpture
\TRF visual arts
\DAT 15-08-14
\DAV 20140815
\SIG AFRIKA 47231
\ISP text
\END
Incorrect macro:
Sub MacroCountry()
' MacroCountry Macro
With ActiveDocument.Content.Find
'Search for \PPN (beginning of the record) and then search for \TRF
.Text = "\PPN"
.Text = "\TRF"
'the selection part of the Macro works fine, it selects the line, duplicates it and changes the field label
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
Selection.MoveRight Unit:=wdWord, Count:=1
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
Selection.TypeText Text:="\Ott "
End With
Loop
End Sub

Answer 1

I'm trying to find out a little bit more about MS Word framework so I used this as exercise. You could try this. Precondition is that all lines are ending with newlines so each line is a paragraph.
Sub InsertLines()
Dim rng As Range
Dim i As Integer
Dim doc As Document
Dim line As String
Dim inBlock As Boolean, found As Boolean
Set doc = ThisDocument
i = 1
While i < ThisDocument.Paragraphs.Count
line = doc.Paragraphs(i).Range.Text
If InStr(line, "\PPN") > 0 Then
inBlock = True
found = False
End If
If InStr(line, "\END") > 0 Then
inBlock = False
End If
If inBlock And Not found Then
If InStr(line, "\TRF") > 0 Then
doc.Paragraphs(i).Range.InsertAfter "\OTT " & Mid(line, 5)
found = True
End If
End If
i = i + 1
Wend
End Sub
I'm sure there are more elegant solutions but I hope this is a solution at all. I tried a little bit with RegExp and Find object but this is more straightforward.