speed up macro to Highlight Phrases in document based on list input from text file

Gontch · #1 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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Speed up macro that calls Excel-based function	Peterson	Word VBA	2	08-11-2020 06:18 AM
Macro To Identify & Highlight Words In MS Word Based Upon A List In Excel File Column	abhimanyu	Word VBA	5	03-20-2020 01:33 PM
Macro to highlight duplicate phrases in document?	taw	Word VBA	0	02-27-2018 01:47 PM
Inserting text from one word file into another based on an excel input	jmaxcy	Excel	14	11-01-2013 04:07 PM
Inserting text from one word file into another based on an excel input	jmaxcy	Word	3	11-01-2013 01:26 AM