VBA Word 从 Excel 中查找和替换 /&-

Posted 2023-03-17

【中文标题】VBA Word 从 Excel 中查找和替换 /&-

【英文标题】：VBA Word Find And Replace From Excel /&-

【发布时间】：2018-01-18 00:54:02

【问题描述】：

我正在创建一个宏来搜索 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

然而，这段代码确保没有任何东西进入数组。

当首字母缩略词中包含特殊字符时如何呈现误报？

【问题讨论】：

有点难看，但您可以 - 使用 Word 文档的一次性版本 - 将所有“&”实例替换为（例如）“aaaaa”、“/”为“bbbbb”等（文档中不可能出现的任何内容） 在运行搜索之前对 Excel 中的任何首字母缩写词执行相同操作：然后它只会找到整个单词“匹配项”。就像我说的，很老套，但应该满足你的要求。

问题是msWord认为“RT&E”是3个词。单步执行这三行并在单步执行时查看您的 Word 文档 For Each wrd In ActiveDocument.Words wrd.Select Next wrd

可能需要对excel表进行排序，以便先找到RT&E，如果文本颜色已经是粉红色则不计算RT

也许 Regex 是要走的路。一些信息：***.com/questions/22542834/…

【参考方案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

【讨论】：

这并没有解决实际问题

@TimWilliams，OP 也在征求建议以改进代码。这个加快了速度，因为它只需要从 excel 中获取数据一次。无法在评论中发布代码

感谢您的回复。宏的速度是一个问题。我无法让上面的代码工作。我通过将“应用程序”更改为“Excel.Application”解决了“找不到方法”。我通过将“Set acro = range...”更改为“Set acro = acrolist.range”解决了“Type Mismatch 4218”，但是当 Find 文本开始时我得到“Type mismatch 9 (subscript not found)”。

@dockert，对错误感到抱歉。请在rng.Find.Text ... 行之前插入debug.print wordsInExcel(i)。并运行代码。让我知道结果

@jsotola 除非我注释掉第二个“.Application.Transpose”，否则代码不会运行。完成此操作后，我按照您的指示插入了“debug.print wordsInExcel(i)”。即时窗口打印出正确的首字母缩略词。该代码并不完全有效，因为只有少数首字母缩略词最终出现在数组中。非常感谢您的帮助。