Microsoft Office Forums - View Single Post - speed up macro to Highlight Phrases in document based on list input from text file

Gontch · 01-20-2021, 05:36 PM

The goal here is to run a macro which will import a list of phrases and highlight them in the document. The text file has phrases separated by line like this :

Miles per Hour
Carbon Dioxide
Supply Fan
ect…

My macro highlights the first occurrence yellow and and following occurrences pink. I also have another list for the acronym which goes with the phrase. So the first occurrence of Miles per Hour and first occurrence of (MPH) will be yellow. I want to replace all the pink phrases with appropriate acronyms as they should be defined now. I have a working macro, but it's ugly and takes forever.

Any advice to cut down the looping process here? It's basically the 3 of the same macros...

Code:

Sub QC_Time()

Call HighlightExtraPhrases
Call HighlightPhrases
Call HighlightAcroynms

End Sub


Sub HighlightPhrases()

Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdYellow
Dim MyString As String
Dim MyAcroFileName As String
Dim rng As Range

    MyAcroFileName = "C:\Users\gontch\Desktop\Phrase Running List.txt"
Open MyAcroFileName For Input As #1

'loop through the file until the end of file marker is reached

Do While Not EOF(1)
    'read line of text, place it in the MyString variable
    Line Input #1, MyString
    'Reset the Range object to the entire current document
    Set rng = ActiveDocument.Range
    rng.Find.Replacement.Highlight = True
    With rng.Find
        .Text = MyString
        .Replacement.Text = MyString
        .MatchCase = False
        .MatchWholeWord = True
        .Execute Replace:=wdReplaceOne
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
            End With
Loop

'close the text file
Close #1
Application.ScreenUpdating = True

End Sub
Sub HighlightExtraPhrases()

Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdPink
Dim MyString As String
Dim MyAcroFileName As String
Dim rng As Range

    MyAcroFileName = "C:\Users\gontch\Desktop\Phrase Running List.txt"
Open MyAcroFileName For Input As #1

'loop through the file until the end of file marker is reached

Do While Not EOF(1)
    'read line of text, place it in the MyString variable
    Line Input #1, MyString
    'Reset the Range object to the entire current document
    Set rng = ActiveDocument.Range
    rng.Find.Replacement.Highlight = True
    With rng.Find
        .Text = MyString
        .Replacement.Text = MyString
        .MatchCase = False
        .MatchWholeWord = True
        .Execute Replace:=wdReplaceAll
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
            End With
Loop

'close the text file
Close #1
Application.ScreenUpdating = True

End Sub

Sub HighlightAcroynms()

Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdYellow
Dim MyString As String
Dim MyAcroFileName As String
Dim rng As Range

    MyAcroFileName = "C:\Users\gontch\Desktop\Acronyms Running List.txt"
Open MyAcroFileName For Input As #1

'loop through the file until the end of file marker is reached

Do While Not EOF(1)
    'read line of text, place it in the MyString variable
    Line Input #1, MyString
    'Reset the Range object to the entire current document
    Set rng = ActiveDocument.Range
    rng.Find.Replacement.Highlight = True
    With rng.Find
        .Text = MyString
        .Replacement.Text = MyString
        .MatchCase = True
        .MatchWholeWord = True
        .Execute Replace:=wdReplaceOne
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
    End With
Loop

'close the text file
Close #1
Application.ScreenUpdating = True

End Sub