Как расширить диапазон, возвращаемый Word VBA Range.Find до конца абзаца

Question

У меня большой текстовый текст со строками, которые должны быть Heading3, но на самом деле это простой текст, начинающийся с ***

Ex.

*** Day 1

Что-то случилось в первый день ... и т.д.

*** Day 2

Что-то случилось в день 2 ... и т.д.

Я пытаюсь выбрать эти строки, удалить слово «3 звезды» и сделать эту строку заголовком 3.

Я также избегаю (лучшая практика?) Использование объекта выделения в vba, и вместо этого сосредоточусь на методе range.find. Я могу легко найти слово ***, но как расширить до конца строки? На самом деле у range.find нет метода расширения. Поэтому я прибегаю к использованию подстановочных знаков ... и я не успешен.

На данный момент я не запустил процесс форматирования кода, так как мне не удалось пройти процесс поиска.

   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

Предположительно, ваш текст находится только в теле документа, и в этом случае - если нет прямого форматирования - вы можете уменьшить код до:

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

Если есть несколько диапазонов истории для обработки, вы можете использовать:

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

Наконец, если есть прямое форматирование, то оно может быть удалено более эффективно без использования выборок. Например:

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

и для обработки всех сюжетов:

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

Answer 2

Теоретически можно было бы найти что-то, указав стиль абзаца как часть замены, и это должно повлиять на весь абзац. Однако возникают проблемы, когда применяемый стиль является «связанным стилем»: стилем, который можно применять как в качестве абзаца, так и в качестве стиля символа. К сожалению, это относится ко всем встроенным стилям заголовков. Применение такого стиля не обязательно изменит форматирование текстовых символов в абзаце - прямое форматирование может переопределиться, так что, хотя абзац отформатирован со стилем, визуально текст может выглядеть иначе.

Следовательно, простого поиска / замены будет недостаточно, поскольку для принудительного правильного форматирования потребуются дополнительные шаги.

У меня работает следующее.

Я предполагаю, что звездочки должны быть удалены, поэтому установите текст замены в пустую строку. В этом сценарии подстановочные знаки не нужны.

Выполнение выполняется в Do...Loop, так что каждый экземпляр термина определяется индивидуально и производится замена. Затем применяется стиль, и диапазон выбран для использования метода ClearCharacterDirectFormatting. Это эквивалентно нажатию клавиши Ctrl + пробел в качестве пользователя и заставляет выделение отображать форматирование стиля абзаца, которое могло быть наложено прямым форматированием шрифта.

Затем необходимо свернуть Range, прежде чем продолжить поиск.

   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

В качестве альтернативы, основанный на оригинальном подходе в вопросе с использованием подстановочных знаков и выделением всего всего абзаца (не предложения), может выглядеть как следующий пример кода. В этом случае текст поиска разбивается на два «выражения»: звездочки и остальная часть абзаца. Текст замены является вторым выражением (\@ - остальная часть абзаца), и в этом сценарии стиль применяется как часть замены.

По-прежнему необходимо выбрать и очистить прямое форматирование, чтобы обеспечить видимость форматирования стиля.

   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