VBA Word Find And Replace From Excel /&- - vba

Question

I am creating a macro to search word documents for exact matches against acronyms in an Excel file. If the acronym is in the Word file, the macro highlights the acronym and inserts the row number into an array for use in a to-be-written macro to generate a Table of Acronyms.
The below macro works, however there are several false positives whenever I run it. This occurs when certain acronyms contain special characters, notably "&", "/" and "-".
For example, if I run the below macro on a file that contains RT&E, the code will insert the row number for "RT and "RT&E" and "T&E" into the array (provided all three are in the first column in the excel file).
This is not a problem on small documents, but for 150 page documents, it's just too much. I also apologize for the bad code. Suggestions to make it better are appreciated.
Dim rng As range
Dim i As Long
Dim acro As String
Dim acrolist As Excel.Application
Dim acrobook As Excel.Workbook
Dim acromatch() As Variant
ReDim acromatch(0 To 1)
Set acrolist = New Excel.Application
Set acrobook = acrolist.Workbooks.Open("P:\AcronymMacro\MasterAcronymList.xlsm")
' Count from first row with acronym to maximum # of rows
' That way, list can be as long or short as needed
For i = 3 To 1048576
Set rng = ActiveDocument.range
acro = acrobook.Sheets(1).Cells(i + 1, 1)
' Loop breaks when it finds an empty cell
' i.e. the last acronym in the document.
If acro = "" Then Exit For
' Find and Replace code
With rng.Find
.Text = acro
.Format = True
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
' Do While loop
Do While .Execute(Forward:=True) = True
rng.HighlightColorIndex = wdPink
Call InsertIntoArray(acromatch(), i + 1)
Loop
End With
Next
MsgBox Join(acromatch(), ",")
'Make sure you close your files, ladies and gentlemen!
acrobook.Close False
Set acrolist = Nothing
Set acrobook = Nothing
' This function resizes array and insert value as last value
Public Function InsertIntoArray(InputArray As Variant, Value As Variant)
ReDim Preserve InputArray(LBound(InputArray) To UBound(InputArray) + 1)
InputArray(UBound(InputArray)) = Value
End Function
One thing I tried was to run another Range.Find method in the Do While Loop, with a slight change to the acronym. For instance the below code makes sure there is a space, period, or close parentheses and not an ampersand and hyphen after the acronym. If it is different, then it doesn't get added.
Do While .Execute(Forward:=True) = True
rng.HighlightColorIndex = wdPink
acro = acro + "[ .)]"
With rng.Find
.Text = acro
.MatchWildCards = True
If rng.Find.Execute(Forward=True) = True Then Call InsertIntoArray(acromatch(), i + 1)
End With
Loop
This code, however, makes sure nothing gets into the array.
How to I present false positives when acronyms have special characters in acronyms?

Answer 1

here is a rewrite of your code
it puts the data from excel into an array, then the array is searched
no correction made for the problem with special characters
Sub acroTest()
Dim acromatch() As Variant
ReDim acromatch(0 To 1)
Dim acrolist As Excel.Application
Set acrolist = New Excel.Application
Dim acrobook As Excel.Workbook
Set acrobook = acrolist.Workbooks.Open("P:\AcronymMacro\MasterAcronymList.xlsm")
Dim rng As Range ' msWord range
Set rng = ActiveDocument.Range
With rng.Find ' set up find command
.Format = True ' these are "remembered" until changed
.MatchCase = True ' same as the "find" dialog box
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
' Count from first row with acronym to maximum # of rows
' That way, list can be as long or short as needed
' could loop excel range this way
' constant xlCellTypeConstants = 2
' Dim acro As Excel.Range
' For Each acro In acrobook.Sheets(1).Range("a3:a1048576").SpecialCells(xlCellTypeConstants) ' all non-blank, non-formula cells
Dim acro As Excel.Range
Set acro = acrolist.Range(acrobook.Sheets(1).Range("A3"), acrobook.Sheets(1).Cells(1048576, "A").End(xlUp)) ' range A3 to last used cell in A column
Dim wordsInExcel As Variant ' column A gets put into an array for faster execution
wordsInExcel = acro.Value ' convert excel range to 2d array (1 x N)
wordsInExcel = acrolist.Transpose(wordsInExcel) ' convert result to 2d array (N x 1)
wordsInExcel = acrolist.Transpose(wordsInExcel) ' convert again to get 1d array
Dim i As Long
For i = 1 To UBound(wordsInExcel)
rng.Find.Text = wordsInExcel(i) ' this is "search text"
Do While rng.Find.Execute(Forward:=True) = True ' do the actual search
rng.HighlightColorIndex = wdPink
Call InsertIntoArray(acromatch(), i + 1)
Loop
Next
MsgBox Join(acromatch(), ",")
' Make sure you close your files, ladies and gentlemen!
acrobook.Close False
Set acrolist = Nothing
Set acrobook = Nothing
End Sub
' This function resizes array and insert value as last value
Public Function InsertIntoArray(InputArray As Variant, Value As Variant)
ReDim Preserve InputArray(LBound(InputArray) To UBound(InputArray) + 1)
InputArray(UBound(InputArray)) = Value
End Function