Найдите слова с несколькими заглавными буквами в слове / VBA и соберите их в отдельный документ

Question

Я нашел часть решения в следующем вопросе:

Найти слова, содержащие более одной заглавной буквы в слове / VBA

Этот код был очень полезным для моей главной проблемы автоматический поиск слов с более чем одной заглавной буквой. Вместо того, чтобы выделять их зеленым цветом, я хотел бы извлечь каждое найденное слово в таблицу в дополнительном документе и отсортировать найденные акронимы по алфавиту. К сожалению, я понятия не имею, как это можно сделать.

Я нашел некоторый код, который делает это, но его поиск акронима является субоптимальным.

Может кто-нибудь помочь мне, пожалуйста?

Sub ExtractAcronymsToNewDocument() 
'Finds all words consisting of 3 or more uppercase letters
'in active document document and inserts the words
'in column 1 of a 3-column table in a new document
'Each acronym is added only once
'Room for definition in column 2
'Page number of first occurrence is added in column 3


Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String 'use to keep track of foudnd


'Find the list separator from international settings
'In some countries it is comma, in other semicolon
strListSep = Application.International(wdListSeparator)


strAllFound = "#"


Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add


With oDoc_Target
    'Make sure document is empty
    .Range = ""


    'Insert a table with room for acronym and definition
    Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
    With oTable
        'Format the table a bit
        'Insert headings
        .Cell(1, 1).Range.Text = "Acronym"
        .Cell(1, 2).Range.Text = "Definition"
        .Cell(1, 3).Range.Text = "Page"
        'Set row as heading row
        .Rows(1).HeadingFormat = True
        .Rows(1).Range.Font.Bold = True
        .PreferredWidthType = wdPreferredWidthPercent
        .Columns(1).PreferredWidth = 20
        .Columns(2).PreferredWidth = 70
        .Columns(3).PreferredWidth = 10
    End With
    End With
    With oDoc_Source
    Set oRange = .Range
    n = 1 'used to count below


    With oRange.Find
        .Text = "<[A-Z]{3" & strListSep & "}>"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = True
        .MatchWildcards = True
        Do While .Execute
            'Continue while found
            strAcronym = oRange
            'Insert in target doc


            'If strAcronym is already in strAllFound, do not add again
            If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
                'Add new row in table from second acronym
                If n > 1 Then oTable.Rows.Add
                'Was not found before
                strAllFound = strAllFound & strAcronym & "#"


                'Insert in column 1 in oTable
                'Compensate for heading row
                With oTable
                    .Cell(n + 1, 1).Range.Text = strAcronym
                    'Insert page number in column 3
                    .Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
                End With


                n = n + 1
            End If


            'If acronym
        Loop
    End With
    End With
'Sort the acronyms alphabetically
With Selection
    .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
        :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending


    .HomeKey (wdStory)
End With


'Clean up
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing


MsgBox "Finished extracting " & n - 1 & " acronymn(s) to a new document."


End Sub 

BR Патрик