vbams-wordword-style

MS Word VBA - Finding a word and changing its style


I'm trying to find all instances of key words in a MS Word document and change their style. The key words are stored within an array and I want to change the style of the particular word only. Ideally this would happen as I type but that is not crucial.

Attempt 1 - Based on recording a macro and changing the search term

Sub Woohoo()
Dim mykeywords
mykeywords= Array("word1","word2","word3")

For myword= LBound(mykeywords) To UBound(mykeywords)

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("NewStyle")
    With Selection.Find
        .Text = mykeywords(myword)
        .Replacement.Text = mykeywords(myword)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next

End Sub

This changes the style of the entire paragraph where the words are in.

Attempt 2 - Based on this question here How can I replace a Microsoft Word character style within a range/selection in VBA?:

Sub FnR2()
Dim rng As Range
Dim mykeywords
mykeywords = Array("word1","word2","word3")

For nKey = LBound(mykeywords) To UBound(mykeywords)
For Each rng In ActiveDocument.Words
    If IsInArray(rng, mykeywords(nKey)) Then
        rng.Style = ActiveDocument.Styles("NewStyle")
    End If
Next
Next

End Sub

This finds words that are in single lines but skips the words that are within a paragraph for some reason, e.g. it finds

Some text
word1
more text

but not

Some text before word1 means that the code above doesn't change the format
Word1 also isn't changed in this instance

Attempt 3 - AutoCorrect; not actually tried:

As an alternative I was thinking to use AutoCorrect. However I have more than 100 keywords and have no idea how to add this to the AutoCorrect list automatically (I'm fairly VBA illiterate). The other problem I would see with this approach is that I believe that AutoCorrect is global, whereas I need this only to work for a specific document.


Solution

  • I believe the reason why your macro isn't finding the words is due to the presence of leading or trailing blank spaces. Providing that you have already defined the style "NewStyle" changing your if statement in SubFnR2 from

    If IsInArray(rng, mykeywords(nKey)) Then
    

    to

    If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
    

    Should solve the issue. By the way if you want to keep the style of the word depending on whether it is upper or lower case then remove the LCase part.

    Edit:

    I have included the sub with the modification below. I have tested it on the examples you gave (cut and pasted into word) and it changed the style for both instances word1.

    Sub FnR3()
    Dim rng As Range
    Dim mykeywords
    mykeywords = Array("word1", "word2", "word3")
    Dim nkey As Integer
    
    For nkey = LBound(mykeywords) To UBound(mykeywords)
    For Each rng In ActiveDocument.Words
    
        If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
            rng.Style = ActiveDocument.Styles("NewStyle")
        End If
    
    Next rng
    Next nkey
    
    End Sub
    

    Ok, your document behaves has you described, I'm not quite sure why. I checked selecting the range and just the word was selected, but then the whole paragraph was formatted. I have modified the code to modify the selection, shown below. This did just change the word.

    Sub FnR4()
    Dim rng As Range
    Dim mykeywords
    mykeywords = Array("word1", "word2", "word3")
    Dim nkey As Integer
    
    For nkey = LBound(mykeywords) To UBound(mykeywords)
        For Each rng In ActiveDocument.Words
            Selection.Collapse
            rng.Select
                If mykeywords(nkey) = LCase(Trim(rng.Text)) Then
                    Selection.Style = ActiveDocument.Styles("NewStyle")
                End If
    
        Next rng
    Next nkey
    
    End Sub