Найти слова с более чем одной заглавной буквой в слове /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

Вы не можете сделать это за один проход Find/Replace. Вы также должны сделать некоторые допущения относительно того, что приложение Word считает 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