Find and replace fields in Word using VBA

[Roderick]

The following code finds a field in a document (highlighted), deletes it and replaces it with two new fields.

It seems to work as required, perhaps not as elegantly written as it could be, but it does the job.


Sub ReplaceFieldsV2()

Application.ScreenUpdating = False
ActiveWindow.View.ShowFieldCodes = True
With Selection
.HomeKey Unit:=wdStory
.Find.ClearFormatting
With Selection.Find
.Text = "^d SEQ Table \* ARABIC"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Find.Execute
.Delete Unit:=wdCharacter, Count:=1
.TypeText Text:=" "

.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"StyleRef " & """GA Numbered Heading 1""" & " \s", PreserveFormatting:=False
.TypeText Text:="-"
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"SEQ " & """Table""" & " \* ARABIC \r 1", PreserveFormatting:=False
End With
ActiveWindow.View.ShowFieldCodes = False
Call SpecialUpdateFields
Application.ScreenUpdating = True

End Sub

This procedure just deals with the first field it comes to. What I want to do is for it to move on to the next field, replace it and then so on for all the other similar fields until no more are found.

I tried researching a For...Loop or a While...Wend but couldn't fathom out where and how to use these. And which would be the best one to employ in this case.

Could someone point me in the right direction, please?

Thanks

Roderick

[gmayor]

I think I would be inclined to loop trough the seq fields themselves e.g. as follows, which should work if the fields are in the body of the document.


Sub ReplaceFieldsV3()
'Graham Mayor - http://www.gmayor.com - Last updated - 24 Sep 2018
Dim oFld As Field, oNewFld As Field
Dim oRng As Range, oSeq As Range
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldSequence Then
If InStr(1, oFld.Code, "Table") > 0 Then
oFld.Code.Text = Replace(oFld.Code.Text, oFld.Code.Text, "SEQ Table \* ARABIC \r 1")
oFld.Update
Set oRng = oFld.Code
oRng.MoveEnd wdCharacter, 1
oRng.Collapse 0
Set oNewFld = ActiveDocument.Fields.Add(Range:=oRng, _
Type:=wdFieldStyleRef, _
Text:="""GA Numbered Heading 1""" & " \s", _
PreserveFormatting:=False)
oNewFld.Update
End If
End If
Next oFld
ActiveWindow.View.ShowFieldCodes = False
lbl_Exit:
Set oFld = Nothing
Set oNewFld = Nothing
Set oRng = Nothing
Exit Sub
End Sub

[Roderick]

Thanks very much Graham for the great Heads Up and it works as you planned.

However, the new added wdStyleRef field has to go before the SEQ field and both fields have to be separated by a single dash character. At the moment, the new field goes after the SEQ and there is no gap between these to allow for a hyphen.

I've tried using using .MoveStart where it says .MoveEnd but this is of course just a character. It has to move (collapse) before the field SEQ then followed by a space.

You may be asking why this is all necessary? Well, these fields are for creating Table Chapter Headings using special styles and not those imposed by Microsoft (Heading 1, etc). Hence the GA Numbered Heading 1 you see in the code. The end result of course will be (chapter) 1-(item) 1 and so on.

Is it possible to achieve this structure, please?

Roderick

[gmayor]

OK. It's just a question of relocating the ranges e.g.


Sub ReplaceFieldsV4()
'Graham Mayor - http://www.gmayor.com - Last updated - 25 Sep 2018
Dim oFld As Field, oNewFld As Field
Dim oRng As Range, oSeq As Range
For Each oFld In ActiveDocument.Fields
If oFld.Type = wdFieldSequence Then
If InStr(1, oFld.Code, "Table") > 0 Then
oFld.Code.Text = Replace(oFld.Code.Text, oFld.Code.Text, "SEQ Table \* ARABIC \r 1")
oFld.Update
Set oRng = oFld.Code
oRng.MoveStart wdCharacter, -1
oRng.Collapse 1
oRng.Text = "-"
oRng.Collapse 1
Set oNewFld = ActiveDocument.Fields.Add(Range:=oRng, _
Type:=wdFieldStyleRef, _
Text:="""GA Numbered Heading 1""" & " \s", _
PreserveFormatting:=False)
oNewFld.Update
End If
End If
Next oFld
ActiveWindow.View.ShowFieldCodes = False
lbl_Exit:
Set oFld = Nothing
Set oNewFld = Nothing
Set oRng = Nothing
Exit Sub
End Sub