Макрос Word VBA для выделения жирным шрифтом части всех экземпляров определенной текстовой строки - PullRequest
Новая
       88

Макрос Word VBA для выделения жирным шрифтом части всех экземпляров определенной текстовой строки

0 голосов
/ 14 сентября 2018

Я использую следующий код, чтобы выделить части текстовой строки жирным шрифтом, в этом случае слово «рыба» заключено в скобки после слова «масло»: 

Sub ReplaceAndFormat16()
Dim sConst1 As String, sReplaceMent As String
Dim rRange As Range, rFormat As Range
sConst1 = "Fish"
sReplaceMent = "Oil (" & sConst1 & ")"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
   .Text = "Oil (Fish)"
    .Replacement.Text = sReplaceMent
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = True
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceOne
    If .Found Then
        Set rRange = Selection.Range
       Set rFormat = ActiveDocument.Range(rRange.Start + 5, rRange.Start + 5 + VBA.Len(sConst1))
       rFormat.Font.Bold = True
   End If
   End With
End Sub

Этот код отлично работает,но только жирный шрифт первого экземпляра, и в моих документах может быть до четырех экземпляров этой фразы, которые необходимо отформатировать жирным шрифтом.Как я могу изменить код, чтобы он сохранил и выделил все экземпляры в документе?Я очень новичок в VBA, поэтому извиняюсь, если это кажется глупым вопросом.

1 Ответ

0 голосов
/ 14 сентября 2018

Изменить строку

.Execute Replace:=wdReplaceOne

до 

.execute Replace:=wdReplaceAll

Редактировать

ОК, вышесказанное было глупым ответом. Код ниже делает правильные вещи 

Sub ReplaceAndFormat16()
Const myFindStr                      As String = "Oil (Fish)"
Dim myFindRange                      As Word.Range

    Set myFindRange = ActiveDocument.StoryRanges(wdMainTextStory)

    Do
        With myFindRange.Find

            .ClearFormatting
            .Text = myFindStr
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False 
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute

            If .Found Then
                With myFindRange
                    .MoveStartUntil cset:="fF"
                    .MoveEndUntil cset:="hH", Count:=wdBackward
                    .Font.Bold = True
                    .Collapse Direction:=wdCollapseEnd
                End With
            Else
                Exit Sub
            End If

        End With

    Loop

End Sub
...