|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
speed up macro to Highlight Phrases in document based on list input from text file
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 |
#2
|
||||
|
||||
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. Code:
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
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. |
Tags |
acronym, highlight, replace |
Thread Tools | |
Display Modes | |
|
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 |