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

[Gontch]

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...

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

[Guessed]

The two phrase macros could be simplified since they are reading the same source file. This would speed up your execution time by a considerable amount.

Then you can also reduce the total amount of code by making the macro into a function (or sub) with inputs. Note that this reduces the amount of code you have to maintain but won't be faster to execute.

Sub QC_Time()
  HighlightPhrases MyAcroFileName:="C:\Users\gontch\Desktop\Phrase Running List.txt", bAll:=True
  HighlightPhrases MyAcroFileName:="C:\Users\gontch\Desktop\Acronyms Running List.txt", bAll:=False
End Sub

Function HighlightPhrases(MyAcroFileName As String, bAll As Boolean)
  Dim MyString As String, rng As Range

  Application.ScreenUpdating = False
    Open MyAcroFileName For Input As #1
      Do While Not EOF(1)                 'loop through the file until the end of file marker is reached
        Line Input #1, MyString           'read line of text, place it in the MyString variable
        Set rng = ActiveDocument.Range    'Reset the Range object to the entire current document
        With rng.Find
          .Text = MyString
          .Replacement.Text = MyString
          .MatchCase = False
          .MatchWholeWord = True
          .Forward = True
          .Replacement.Highlight = True
          If bAll Then
            Options.DefaultHighlightColorIndex = wdPink
            .Execute Replace:=wdReplaceAll
          End If
          Options.DefaultHighlightColorIndex = wdYellow
          .Execute Replace:=wdReplaceOne
         End With
      Loop
    Close #1          'close the text file
  Application.ScreenUpdating = True
End Function

[Gontch]

Excellent work Guessed! Your code looks much cleaner and easier to manipulate. Run-time has been cut down significantly as well from 7 min to 3 min. I was particularly impressed with the simple Boolean function assignment for the inputs.

Looks like I need to cut down on my phrases/acronyms to speed things up. There are hundreds already and most are rarely used.

Thank you very much.