Playing around with your macro, I think the following will work for you:
Option Explicit
Sub AcronymMatcher()
'
' AcronymMatcher Macro
'Graham Mayor - https://www.gmayor.com - Last updated - 14 Nov 2021
'
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim strDef As String
Dim oTable As Table
Dim oRow As Row
Dim oRng As Range
Dim oCell As Range
Dim n As Long, i As Long
Dim m As Long
Dim sTitle As String
Dim sMsg As String
Dim ArrAcr() As Variant, ArrExc() As Variant
Dim colFound As Collection, colNotFound As Collection, colExcluded As Collection
Dim bFound As Boolean
Const sWorkbook As String = "D:\Acronyms.xlsx"
Const sAcronyms As String = "Acronyms"
Const sExcluded As String = "Excluded"
' message box title
sTitle = "Extract Acronyms to New Document"
' Set message box message
sMsg = "This macro finds all Acronyms (consisting of 2 or more " & _
"uppercase letters, Numbers or '/') and their associated definitions. It " & _
"then extracts the words to a table at the current location you have selected" & vbCr & vbCr & _
"Warning - Please make sure you check the table manually after!" & vbCr & vbCr & _
"Do you want to continue?"
' Display message box
If Not MsgBox(sMsg, vbYesNo + vbQuestion, sTitle) = vbYes Then Exit Sub
ArrAcr = xlFillArray(sWorkbook, sAcronyms)
ArrExc = xlFillArray(sWorkbook, sExcluded)
' Stop the screen from updating
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
' give the active document a variable
Set oDoc_Source = ActiveDocument
'Create new document to temporarily store the acronyms
Set oDoc_Target = Documents.Add
' Use the target document
With oDoc_Target
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=1, NumColumns:=2)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
'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
End With
End With
Set colFound = New Collection
Set colNotFound = New Collection
Set colExcluded = New Collection
With oDoc_Source
Set oRng = .Range
' within the total range of the source document
With oRng.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z][A-Z0-9/]{1" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
On Error Resume Next
colFound.Add oRng.Text, oRng.Text
oRng.Collapse 0
Loop
With oTable
For n = 1 To colFound.Count
For m = 0 To UBound(ArrExc, 2)
If colFound(n) = ArrExc(0, m) Then
colExcluded.Add colFound(n), colFound(n)
GoTo Skip
Exit For
End If
Next m
For i = 0 To UBound(ArrAcr, 2)
bFound = False
If colFound(n) = ArrAcr(0, i) Then
Set oRow = .Rows.Add
oRow.HeadingFormat = False
oRow.Range.Font.Bold = False
Set oCell = .Cell(oRow.Index, 1).Range
oCell.End = oCell.End - 1
oCell.Text = ArrAcr(0, i)
Set oCell = .Cell(oRow.Index, 2).Range
oCell.End = oCell.End - 1
oCell.Text = ArrAcr(1, i)
bFound = True
Exit For
End If
If bFound = False Then colNotFound.Add colFound(n), colFound(n)
Next i
Skip:
Next n
'Sort the acronyms alphabetically - skip if only 1 found
If .Rows.Count > 2 Then
.Sort _
ExcludeHeader:=True, _
FieldNumber:="Column 1", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending
End If
If .Rows.Count > 1 Then
oDoc_Source.Range.InsertParagraphAfter
Set oRng = oDoc_Source.Range
oRng.Collapse 0
oRng.FormattedText = .Range.FormattedText
sMsg = "Finished extracting " & .Rows.Count - 1 & " acronym(s)."
Else
sMsg = "No acronyms found."
End If
End With
End With
End With
Set oRng = oTable.Range
oRng.End = oRng.End + 1
oRng.Collapse 0
oRng.Text = vbCr
oRng.Collapse 0
'MsgBox colNotFound.Count & " not found"
If colNotFound.Count > 0 Then
oRng.Text = vbCr & "Not Found: " & vbCr
oRng.Paragraphs(2).Range.Font.Bold = True
oRng.Collapse 0
For i = 1 To colNotFound.Count
oRng.Text = colNotFound(i) & vbCr
oRng.Collapse 0
Next i
End If
'MsgBox colExcluded.Count & " excluded"
If colExcluded.Count > 0 Then
oRng.Text = vbCr & "Excluded: " & vbCr
oRng.Paragraphs(2).Range.Font.Bold = True
oRng.Collapse 0
For i = 1 To colExcluded.Count
oRng.Text = colExcluded(i) & vbCr
oRng.Collapse 0
Next i
End If
' update screen
Application.ScreenUpdating = True
' Show the finished message box
MsgBox sMsg, vbInformation
'oDoc_Target.Close SaveChanges:=wdDoNotSaveChanges
'Clean up
Set oRng = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
Set oCell = Nothing
Set colFound = Nothing
End Sub
Private Function xlFillArray(strWorkbook As String, _
strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long
strRange = strRange & "$]" 'Use this to work with a named worksheet
'strRange = strRange & "]" 'Use this to work with a named range
Set CN = CreateObject("ADODB.Connection")
'Set HDR=NO for no header row
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strRange, CN, 2, 1
With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function