VBA Word Find And Replace From Excel /&-

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