Text replacement

[vik1]

Dear Members,

In my MS-Word template, my client sends template with an error in the header section, as below,

VERMONT , ROBIN A. Date: 10/21/2017
Medical File No: 312325 DOB: 01/05/1982Claim#:
RE155B53452 DOI: 06/21/2017

The error being the ‘Claim#’ coming up right next to the DOB value, while it should come on the next line, as below:



[B]VERMONT , ROBIN A. Date: 10/02/2017
Medical File No: 312325 DOB: 01/05/1982
Claim#: RE155B53452 DOI: 06/21/2017

Also, this error comes up occasionally in some files and not all, so to solve it, I created a word macro, as below:

Sub ShiftClaimNumber2NextLine()

Dim rngStory As Word.Range
Dim lngJunk As Long

lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType

For Each rngStory In ActiveDocument.StoryRanges
Do
With rngStory.Find
.text = "Claim#:"
.Replacement.text = "^pClaim#:"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With

Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next

End Sub
And I run the above macro through a Group Macro, as below:

Sub ProcessAllDocumentsInFolder()

Dim file
Dim path As String

path = "D:\Test\"
file = Dir(path & "*.doc")
Do While file <> ""
Documents.Open FileName:=path & file

Call ShiftClaimNumber2NextLine

ActiveDocument.Save
ActiveDocument.Close

file = Dir()
Loop

End Sub

When I run the macro ProcessAllDocumentsInFolder(), for all files with such an error, it shifts the ‘Claim#’ to the next line.
However, the problem is, it also does so for files that do not have such a problem, thereby adding one enter line below the DOB, as below:


VERMONT, ROBIN S. Date: 10/21/2017
File No: 312335 DOB: 01/05/1982

Claim#: RE155B53452 DOI: 06/21/2017



What changes should I make to my macro ShiftClaimNumber2NextLine() , so that it does not make any change to files which DO NOT HAVE the ‘Claim#’ problem .

Thank you in anticipation,

[macropod]

Try:

Sub ShiftClaimNumber2NextLine()
Dim rngStory As Word.Range
For Each rngStory In ActiveDocument.StoryRanges
Do
With rngStory.Find
.MatchWildcards = True
.Text = "([!^13])(Claim#:)"
.Replacement.Text = "\1^p\2"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With

Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
I omitted your lngJunk code as it does nothing. It's also not clear whether you intend to loop through all story ranges (which is what your code does), or process just the header (which it doesn't).

PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.

[vik1]

Thanks Macropod, Works perfectly, except a small issue that I missed out in my earlier post.

The DOB value is enclosed within a bookmark - 01/05/1982 , as in attached 1st image. Your macro works perfectly, solving my issue, except on running the macro, the last digit in the DOB value comes out of the bookmark, as in attached 2nd image.

Can we avoid this ? Help through slightly tweaking your macro, would be greatly appreciated.

20899

20900

[macropod]

Try:

Sub ShiftClaimNumber2NextLine()
Dim rngStory As Word.Range
For Each rngStory In ActiveDocument.StoryRanges
Do
With rngStory
With .Find
.MatchWildcards = True
.Text = "[!^13]Claim#:"
.Replacement.Text = ""
.Wrap = wdFindStop
.Execute
End With
Do While .Find.Found = True
.Start = .Start + 1
.InsertBefore vbCr
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub

[vik1]

Thanks a Million, Macropod. Works perfectly now !