在word/VBA中查找多个大写字母的单词

Question

我有一段 VBA 代码使用Find 来查找文档中的所有首字母缩写词。它通过搜索由 2 个或更多字符长的大写字母组成的所有单词来实现这一点...

<[A-Z]{2,}>

问题在于它无法识别所有首字母缩略词，例如 CoP、W3C、DVD 和 CD-ROM。它分两部分选取带连字符的首字母缩略词，这些部分并不理想，但在用户检查列表时是允许的。我还可以通过不使用搜索到单词末尾来选择以“s”或其他字符结尾的单词...

<[A-Z]{2,}

但这不会将任何非大写字符作为它找到的单词的一部分。

是否有一个表达式可以让我在任何位置搜索具有两个或多个大写字母的单词并找到整个单词？

Answer 1

我认为“在任何位置搜索具有两个或多个大写字母的单词并找到整个单词”是不可能的，除非与宏代码结合使用。无论如何，由于您使用的是宏，因此这是一种使用以下示例文本对我有用的方法

CoP, this That and AnoTher thing W3C, DVDs and CD-ROM

还有这个通配符组合（请注意，我的 Windows 配置中的列表分隔符是 ;，对于其他地区可能需要 ,）。

<[A-Z][0-9A-Z\-a-z]{1;10}>

以下函数检查“找到”范围内的第二个或任何后面的字母是否大写，并向调用过程返回一个布尔值。它遍历给定Range 中的字符，检查ASCII 值。一旦找到，循环退出。

Function ContainsMoreThanOneUpperCase(rng As Word.Range) As Boolean
    Dim nrChars As Long, i As Long
    Dim char As String
    Dim HasUpperCase

    HasUpperCase = False
    nrChars = rng.Characters.Count
    For i = 2 To nrChars
        char = rng.Characters(i).text
        If Asc(char) >= 65 And Asc(char) <= 90 Then
            'It's an uppercase letter
            HasUpperCase = True
            Exit For
        End If
    Next
    ContainsMoreThanOneUpperCase = HasUpperCase
End Function

一个使用它的例子：

Sub FindAcronyms()
    Dim rngFind As Word.Range
    Dim bFound As Boolean

    Set rngFind = ActiveDocument.content
    With rngFind.Find
        .text = "<[A-Z][0-9A-Z\-a-z]{1;10}>"
        .MatchWildcards = True
        .Forward = True
        .wrap = wdFindStop
        bFound = .Execute
        Do While bFound
            If bFound And ContainsMoreThanOneUpperCase(rngFind) Then
                Debug.Print rngFind.text
                rngFind.HighlightColorIndex = wdBrightGreen
            End If
            rngFind.Collapse wdCollapseEnd
            bFound = .Execute
        Loop
    End With
End Sub

Answer 2

您无法在一次查找/替换中完成此操作。您还必须考虑 Word 应用程序所认为的单词以及首字母缩略词在句子或段落中的位置。

下面的代码应该提供一个想法，让您了解如何结合通配符搜索和其他 VBA 字符串操作来执行此操作。

它被设置为处理以大写字母开头的单词，如果您希望有任何以小写字母开头的单词，您需要进一步携带它并为以小写字母开头的单词添加代码和通配符搜索条件。

Sub FindAcronynms()
    Dim rng As word.Range
    Set rng = ActiveDocument.Content
    With rng.Find
        .ClearFormatting
        .Format = False
        .Forward = True
        .MatchWildcards = True
        .Text = "<[A-Z]{1,}[a-z][A-Z]>"
        .Wrap = wdFindStop
        .Execute
        Do While .found
            MoveEndOfString rng
            rng.HighlightColorIndex = wdTeal
            rng.Collapse wdCollapseEnd
            .Execute
        Loop
    End With
    Set rng = ActiveDocument.Content
    With rng.Find
        .ClearFormatting
        .Format = False
        .Forward = True
        .MatchWildcards = True
        .Text = "[A-Z]{1,5}[0-9][A-Z]{1,5}"
        .Wrap = wdFindStop
        .Execute
        Do While .found
            MoveEndOfString rng
            rng.HighlightColorIndex = wdTeal
            rng.Collapse wdCollapseEnd
            .Execute
        Loop
    End With
    Set rng = ActiveDocument.Content
    With rng.Find
        .ClearFormatting
        .Format = False
        .Forward = True
        .MatchWildcards = True
        .Text = "<[A-Z]{2,}>"
        .Wrap = wdFindStop
        .Execute
        Do While .found
            MoveEndOfString rng
            rng.HighlightColorIndex = wdTeal
            rng.Collapse wdCollapseEnd
            .Execute
        Loop
    End With
    MsgBox "Action Complete", vbExclamation, "Custom Find"
End Sub
Private Function MoveEndOfString(ByRef rng As word.Range)
    rng.MoveEnd wdCharacter, 1
    Select Case Asc(rng.Characters.Last)
        Case Is <= 32
            rng.MoveEnd wdCharacter, -1
        Case 45
            rng.MoveEnd wdCharacter, 1
            rng.MoveEnd wdWord, 1
            If Asc(rng.Characters.Last) = 32 Then
                'required because move above includes
                'trailing space
                rng.MoveEnd wdCharacter, -1
            End If
    End Select
End Function

Answer 3

你可能会使用类似的东西：

Sub Demo()
Application.ScreenUpdating = False
Options.DefaultHighlightColorIndex = wdPink
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Highlight = True
    .Forward = True
    .Format = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "<[A-Z][A-Z0-9/-]{1,}"
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
    .Text = "<[A-Z][A-Za-z0-9/-]@[A-Z]"
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub