VBA Word найти и заменить из Excel /&-

Question

Я создаю макрос для поиска документов Word для точных совпадений с аббревиатурами в файле Excel. Если аббревиатура находится в файле Word, макрос выделяет аббревиатуру и вставляет номер строки в массив для использования в макросе, который должен быть записан, для создания таблицы акронимов.

Приведенный ниже макрос работает, однако при каждом запуске есть несколько ложных срабатываний. Это происходит, когда некоторые аббревиатуры содержат специальные символы, особенно "&", "/" и "-".

Например, если я запускаю приведенный ниже макрос для файла, который содержит RT&E, код вставит номер строки для "RT и"RT&E"и"T&E"в массив (при условии, что все три находятся в первом столбце в файле Excel).

Это не проблема для небольших документов, но для 150-страничных документов это слишком много. Я также прошу прощения за плохой код. Предложения, чтобы сделать это лучше, приветствуются.

    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

Я попытался запустить еще один метод Range.Find в цикле Do While с небольшим изменением аббревиатуры. Например, приведенный ниже код гарантирует, что в скобках есть пробел, точка или закрывающие скобки, а после аббревиатуры нет амперсанда и дефиса. Если это отличается, то это не добавляется.

   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

Этот код, однако, гарантирует, что в массив ничего не попадет.

Как представить ложные срабатывания, когда в акронимах есть специальные символы в акронимах?

Answer 1

Вот переписать твой код

он помещает данные из Excel в массив, а затем в массиве

исправление проблемы со специальными символами не производится

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