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

我尝试过的一件事是在 Do While 循环中运行另一个 Range.Find 方法，只是对首字母缩写词稍作改动。例如，下面的代码确保首字母缩略词后有空格、句点或右括号，而不是 & 和连字符。如果不同，则不会添加。

   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