Sub Highlight_Words_From_Excel_NamedRange()

Const strWorkbook As String = "E:\Database\wordlist.xlsx"
Const strRange As String = "WordList"
Dim arr() As Variant
Dim lngRows As Long
Dim oRng As Range
Dim strFind As String
    arr = xlFillArray(strWorkbook, strRange)
    For lngRows = 0 To UBound(arr, 2)
        strFind = arr(0, lngRows)
        Set oRng = ActiveDocument.Range
        With oRng.Find
            Do While .Execute(findText:=strFind)
                oRng.HighlightColorIndex = wdTurquoise
                oRng.Collapse 0
            Loop
        End With
    Next lngRows
lbl_Exit:
    Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant

Dim RS As Object
Dim CN As Object
Dim iRows As Long

    strRange = strRange & "]"
    Set CN = CreateObject("ADODB.Connection")

    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=NO;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

Sub CopyHighlightsToOtherDoc()
    Dim ThisDoc As Document
    Dim ThatDoc As Document
    Dim r As Range
    Set ThisDoc = ActiveDocument
    Set r = ThisDoc.Range
    Set ThatDoc = Documents.add
    With r
        With .Find
            .Text = ""
            .Highlight = True
            .Font.Name = "Times New Roman"
            .Font.Bold = True
        End With
        Do While .Find.Execute(Forward:=True) = True
            ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
            ThatDoc.Range.InsertParagraphAfter
            .Collapse 0
        Loop
    End With
   
End Sub

Option Explicit ' Helps to ensure your code is good

Sub Runme()
'*** Run this procedure
'Require Reference to Microsoft Word 16.0 Object Library
'This code will work for a standard word document with at least one 2 column table

Dim wdApp As Word.Application
Dim WdDoc As Word.Document
Dim wdTable As Word.Table
Dim i As Integer
    On Error GoTo ErrHandler
    
    Set wdApp = CreateObject("Word.Application")   ' Open Word document
    Set WdDoc = wdApp.Documents.Open(OpenFile)    ' Open the word document - Will run the function above
    Set wdTable = WdDoc.Tables(1)                  ' Reference table by number
    ' **** Activate if you want to see the Doc.  otherwise, leave outta sight for speed.
    'wrdApp.Visible = True
    'wrdApp.Activate
    
    'Copies Cell to Excel by looping through each row in the word document.
    'Cell(i,1) is first column, Cell(i,2) is second column.
    With wdTable
        For i = 1 To .Rows.Count
            'Sheet1 (Excel) = Word table cell
            Sheet1.Cells(i, 1).Value = CorrectCellString(.Cell(i, 1).Range.Text)
            Sheet1.Cells(i, 2).Value = CorrectCellString(.Cell(i, 2).Range.Text)
        Next i
    End With
    Sheet1.Cells(1, 1).Select ' Return cell selection to row 1, column 1
    
Finishup:
    'Close Doc and Release
    WdDoc.Close
    wdApp.Quit
    Set wdApp = Nothing
    Set WdDoc = Nothing
    Set wdTable = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Number & vbCrLf & Err.Description ' Tell me what went wronog
    GoTo Finishup
End Sub

Function CorrectCellString(StrString As String) As String
'Purpose:  correct the cell string from word - removes paragraph markers, etc
    CorrectCellString = Left(StrString, Len(StrString) - 2)
End Function

Function OpenFile() As String
'Opens Word document from user selection
Dim fd As Office.FileDialog
Dim strFile As String
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Word Files", "*.docx", 1
        .Title = "Choose an Excel file"
        .AllowMultiSelect = False
        .InitialFileName = "C:\VBA Folder"
        If .Show = True Then
            strFile = .SelectedItems(1)
            OpenFile = strFile
        End If
    End With
End Function

Option Explicit

Private Const xlWB As String = "C:\Path\Empty Excel File name.xlsx"
Private Const xlSheet As String = "Sheet1"

Sub ExtractText()
Dim oDoc As Document
Dim oRng As Range
    Set oDoc = ActiveDocument
    Set oRng = oDoc.Range
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Name = "Times New Roman"
        .Font.Bold = True
        Do While .Execute()
            If oRng.Text Like "Speaker*" Then
                WriteToWorksheet xlWB, xlSheet, oRng.Text
            End If
        Loop
    End With
lbl_Exit:
    Exit Sub
End Sub

Private Function WriteToWorksheet(strWorkbook As String, _
                                  strRange As String, _
                                  strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function