MS Word Macros
MS Word Macros
inspired by author Jill Tew (@jtewwrites on Threads)
IMPORTANT NOTES
I am by no means a coding expert, this macro is clanky - I approached it in a stepwise manner that made sense for my own processing but there is probably a far more elegant solution out there somewhere.
This macro was written for MS Word on a PC (Windows). It will break if used on MacOS - I might eventually come up with a MacOS version, spoons / time allowing.
Because manuscript lengths vary greatly, this macro scans one chapter at a time. I was worried about it taking too much time, and/or crashing if used on a very long document. I may update it in future to scan several chapters at a time.
In my testing, it took 1 - 2 minutes to analyze a single ~1800-word chapter
If it appears frozen, I'd give it at least 5 minutes before ending the process/task via task manager
Chapters must be named in this format: "Chapter X" where X is a whole number
The macro may not work as intended on documents with tracked changes turned on or with unresolved comments.
Backing up your work before using this macro is highly recommended
'this is a macro that searches for and highlights duplicated words within a dynamic 200-word window
'this macro works by scanning one chapter at a time
'this macro is written for Windows and may not work on MacOS
'this macro may not work if tracked changes are active or if the document contains unresolved comments
'chapters must be named as "Chapter X" where X is a whole number
'it should remember the last chapter that was analyzed but it may lose that information if the document is closed
Sub DynamicHighlightWordEchoes()
'THIS SECTION OF THE SUBROUTINE ASKS FOR USER INPUT TO DETERMINE WHICH CHAPTER TO ANALYZE
'stop the screen from updating / flickering while the macro runs
Application.ScreenUpdating = False
Static lastChapterAnalyzed As Variant 'stores the value of the last chapter that was analyzed
Dim chapInput As String
Dim isValid As Boolean
'if a previous run exists, inform the user before asking for the new input
If Not IsEmpty(lastChapterAnalyzed) Then
MsgBox "The last chapter analyzed was Chapter " & lastChapterAnalyzed & ".", vbInformation, "Previous Session Found"
Else
MsgBox "No chapters have been analyzed yet.", vbInformation, "Welcome"
End If
isValid = False
'ask the user to provide a chapter number for analysis, loop until they provide a valid integer or cancel
Do
chapInput = InputBox("Please enter the chapter number for analysis (numerical values only):", "Chapter Selection")
'exit if the user clicked cancel or left it blank
If Trim(chapInput) = "" Then
MsgBox "No chapter entered. Action cancelled.", vbExclamation, "Cancelled."
Exit Sub
End If
'validate input to make sure it is an integer
If IsNumeric(chapInput) And InStr(chapInput, ".") = 0 Then
'check that the user entry fits within standard integer limits
If Val(chapInput) >= -32768 And Val(chapInput) <= 32767 Then
isValid = True
End If
End If
'if user entry is not valid, warn them and loop back
If Not isValid Then
MsgBox ("Please enter a whole number without letters or decimals")
End If
Loop Until isValid
Dim ch As Integer
'declare user entry strictly as integer
ch = CInt(chapInput)
'save the current entry as the last chapter analyzed to inform the next run
lastChapterAnalyzed = ch
'THIS NEXT SECTION OF THE SUBROUTINE FINDS THE DESIRED CHAPTER AND SELECTS ITS TEXT
Dim startRange As Range
Dim endRange As Range
Dim finalRange As Range
Dim currentChap As String
Dim nextChap As String
Set startRange = ActiveDocument.Range
Set endRange = ActiveDocument.Range
Set finalRange = ActiveDocument.Range
'establish the chapter search terms
currentChap = "Chapter " & ch
nextChap = "Chapter " & (ch + 1)
'find "Chapter ch"
startRange.Find.ClearFormatting
startRange.Find.Text = currentChap
startRange.Find.Execute
If startRange.Find.Found Then
'find "Chapter ch+1"
endRange.Find.ClearFormatting
endRange.Find.Text = nextChap
endRange.Find.Execute
'create the selection range
'start right at the end of the text "Chapter ch"
finalRange.Start = startRange.End
If endRange.Find.Found Then
'end right before the text "Chapter ch+1"
finalRange.End = endRange.Start
Else
'if "Chapter ch+1" doesn't exist, select to the end of the document itself
finalRange.End = ActiveDocument.Content.End
End If
'select the specified content between "Chapter ch" and "Chapter ch+1"
finalRange.Select
Else
'return an error message if "Chapter ch" wasn't found
MsgBox currentChap & " wasn't found in the document."
End If
'THIS NEXT SECTION OF THE SUBROUTINE ESTABLISHES A DYNAMIC / SHIFTING 200-WORD WINDOW AND HIGHLIGHTS DUPLICATED WORDS INSIDE THAT WINDOW
Dim srcWordRange As Range
Dim compWordRange As Range
Dim currentWord As String
Dim compareWord As String
Dim colorIndex As Long
Dim wordCount As Long
Dim foundMatch As Boolean
Dim excludeList As Object
Dim allowedColors As Variant
'Initialize exclusion dictionary - a list of common/function words to exclude from the search
Set excludeList = CreateObject("Scripting.Dictionary")
excludeList.CompareMode = 1 ' Case-insensitive
'add (or remove if needed) words to the exclusion list
Dim varWords As Variant, w As Variant
varWords = Array("a", "an", "the", _
"and", "but", "or", "for", "nor", "so", "yet", _
"in", "on", "at", "to", "for", "of", "with", "by", "from", "up", "about", "into", "over", "after", _
"I", "me", "my", "mine", "he", "him", "his", "she", "her", "hers", _
"it", "its", "you", "your", "yours", "they", "them", "their", "theirs", "we", "us", "our", "ours", _
"am", "are", "was", "were", "be", "been", "being", _
"have", "has", "had", _
"what", "this", "that", "these", "those", "when", "then", "where", "there", "here", "who", "whom", "whose", _
"as", "if", "not", "no")
For Each w In varWords
excludeList(w) = True
Next w
'Restrict highlighting colors (these are chosen for high contrast against black text
allowedColors = Array(wdRed, wdYellow, wdBrightGreen, wdTurquoise, wdPink)
colorIndex = 0 ' Start at the first color in the list
'Loop through every word sequentially
For Each srcWordRange In finalRange.Words
currentWord = Trim(srcWordRange.Text)
'Skip if too short, already highlighted, or in exclusion list
If Len(currentWord) > 1 And _
srcWordRange.HighlightColorIndex = wdNoHighlight And _
Not excludeList.Exists(currentWord) Then
'Create the lookahead pointer
Set compWordRange = srcWordRange.Duplicate
wordCount = 0
foundMatch = False
'Look ahead exactly 200 words
Do While wordCount < 200
compWordRange.MoveStart wdWord, 1
compWordRange.MoveEnd wdWord, 1
'Stop if we exit boundaries
If compWordRange.End > finalRange.End Then Exit Do
compareWord = Trim(compWordRange.Text)
'Case-insensitive match check
If StrComp(currentWord, compareWord, vbTextCompare) = 0 Then
compWordRange.HighlightColorIndex = allowedColors(colorIndex)
foundMatch = True
End If
wordCount = wordCount + 1
Loop
'Highlight the source word if matches were found, then cycle colors
If foundMatch Then
srcWordRange.HighlightColorIndex = allowedColors(colorIndex)
'Cycle to next color in the highlight list
colorIndex = colorIndex + 1
If colorIndex > UBound(allowedColors) Then colorIndex = 0
End If
End If
Next srcWordRange
'Restore settings
Application.ScreenUpdating = True
End Sub