How to expand the range returned by Word VBA Range.Find till the end of paragraph

Question

I have a large amount of word text with lines supposed to be Heading3 but are actually simple text that start with ***

Ex.

*** Day 1

Something happened on day 1... etc

*** Day 2

Something happened on day 2... etc

I am trying to select those lines, delete the 3 stars word, and make that line as heading3.

I am also avoiding (best practice?) the use of selection object in vba, and am focusing instead on the range.find method. I can easily find the *** word, but how to expand to the end of line? In fact the range.find does not have an expansion method. So I am resorting to the use of wildcards... and I am not successful.

For the moment I did not start the formatting process of the code, as I did not manage to pass the finding process.

   Sub FindAndReplace3Stars()
    Dim myStoryRange As Range   
    For Each myStoryRange In ActiveDocument.StoryRanges
     With myStoryRange.Find
      .Text = "<\*\*\*>*^13"
      .Replacement.Text = "B"
      .MatchWildcards = True 
      .Wrap = wdFindContinue 
      .Execute Replace:=wdReplaceAll
      End With
     Next myStoryRange
    End Sub

Answer 1

Theoretically, it would be possible to find something, specifying a paragraph style as part of the replacement, and it should affect the entire paragraph. This has problems, however, when the style to be applied is a "linked style": a style that can be applied both as a paragraph and as a character style. Unfortunately, this is the case for all the built-in Heading styles. Applying such a style will not necessarily change the formatting of the text characters in the paragraph - direct formatting might override so that, while the paragraph is formatted with the style, visually the text may appear different.

Therefore, a simple Find/Replace will not suffice as additional steps become necessary to force the correct formatting.

The following works for me.

I assume the asterisks should be removed so set the replacement text to an empty string. Wildcards are not necessary in this scenario.

Execution is in a Do...Loop so that each instance of the term is found individually and the replacement made. Then the style is applied and the range is selected in order to use the ClearCharacterDirectFormatting method. This is the equivalent of pressing Ctrl+Spacebar as a user and forces the selection to display the paragraph style's formatting that may have been overlayed by direct font formatting.

It's then necessary to collapse the Range before continuing the Find.

   Sub FindAndReplace3Stars()
    Dim myStoryRange As Range
    Dim sFindTerm As String

    sFindTerm = "***"
    For Each myStoryRange In ActiveDocument.StoryRanges
       With myStoryRange.Find
        .Text = sFindTerm
        .Replacement.Text = ""
        .wrap = wdFindStop
        Do While .Execute(Replace:=wdReplaceOne)
          myStoryRange.style = wdStyleHeading3
          myStoryRange.Select
          With Selection
              .ClearCharacterDirectFormatting
          End With
          myStoryRange.Collapse wdCollapseEnd
        Loop
      End With
     Next myStoryRange
   End Sub

Alternately, based on the original approach in the question using wildcards and selecting the entire paragraph (not sentence) could look like the following code sample. In this case, the search text is broken into two "expressions": the asterisks and the rest of the paragraph. The replacement text is the second expression (\@ - the rest of the paragraph) and in this scenario the style is applied as part of the replacement.

It's still necessary to select and clear the direct formatting in order to ensure that the style formatting is visible.

   Sub FindAndReplace3Stars_Alternate()
    Dim myStoryRange As Range
    Dim sFindTerm As String

    sFindTerm = "(\*\*\*)(?*^013)"
    For Each myStoryRange In ActiveDocument.StoryRanges
     With myStoryRange.Find
        .Text = sFindTerm
        .Replacement.Text = "\2"
        .Replacement.style = wdStyleHeading3
        .MatchWildcards = True
        .wrap = wdFindStop
        Do While .Execute(Replace:=wdReplaceOne)
            myStoryRange.Select
            With Selection
                .ClearCharacterDirectFormatting
            End With
            myStoryRange.Collapse wdCollapseEnd
        Loop
      End With
     Next myStoryRange
    End Sub

Answer 2

Presumably your text is only in the document body, in which case - unless there is direct formatting - you could reduce the code to:

Sub FindAndReplace3Stars()
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[\*]{3}[ ]{1,}(*^13)"
  .Replacement.Text = "\1"
  .Replacement.Style = wdStyleHeading3
  .MatchWildcards = True
  .Wrap = wdFindContinue
  .Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub

If there are multiple story ranges to process, you could use:

Sub FindAndReplace3Stars()
Application.ScreenUpdating = False
Dim Rng As Range
For Each Rng In ActiveDocument.StoryRanges
  With Rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Text = "[\*]{3}[ ]{1,}(*^13)"
    .Replacement.Text = "\1"
    .Replacement.Style = wdStyleHeading3
    .MatchWildcards = True
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
Next
Application.ScreenUpdating = True
End Sub

Finally, if there is direct formatting, that can be removed more efficiently without using selections. For example:

Sub FindAndReplace3Stars()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[\*]{3}*^13"
    .MatchWildcards = True
    .Wrap = wdFindStop
    .Execute
  End With
  Do While .Find.Found = True
    .Style = wdStyleHeading3
    .Text = Trim(Split(.Text, "***")(1))
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub

and, to process all storyranges:

Sub FindAndReplace3Stars()
Application.ScreenUpdating = False
Dim Rng As Range
For Each Rng In ActiveDocument.StoryRanges
  With Rng
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "[\*]{3}*^13"
      .Replacement.Text = ""
      .MatchWildcards = True
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found = True
      .Style = wdStyleHeading3
      .Text = Trim(Split(.Text, "***")(1))
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub