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