Sub AddHyperlinks()

    ' Open the Excel file containing the hyperlinks
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Open("C:\Path\To\Hyperlinks.xlsx")
    
    ' Loop through each occurrence of "Secretary" in the document
    Dim doc As Document
    Set doc = ActiveDocument
    Dim rng As Range
    Set rng = doc.Content
    Dim counter As Integer
    counter = 1
    Do While rng.Find.Execute("Secretary", MatchWholeWord:=True)
        ' Add the hyperlink to this occurrence of "Secretary"
        Dim hyperlink As String
        hyperlink = xlWB.Sheets(1).Cells(counter, 1).Value
        Dim linkRange As Range
        Set linkRange = rng.Duplicate
        linkRange.Collapse Direction:=wdCollapseStart
        linkRange.MoveEndUntil Cset:=" "
        rng.Hyperlinks.Add Anchor:=linkRange, Address:=hyperlink
        counter = counter + 1
    Loop
    
    ' Close the Excel file
    xlWB.Close
    xlApp.Quit
End Sub

Option Explicit
Const strWB As String = "C:\Path\To\Hyperlinks.xlsx"
Const strSheet As String = "Sheet1"

Sub AddHyperlinks()
Dim oDoc As Document
Dim oRng As Range
Dim Arr() As Variant
Dim i As Long
Dim sName As String, sLink As String
    Set oDoc = ActiveDocument
    Arr = xlFillArray(strWB, strSheet)
    For i = 0 To UBound(Arr, 2)
        sName = Arr(0, i)
        sLink = Arr(1, i)
        Set oRng = oDoc.Range
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(findText:=sName)
                If oRng.Hyperlinks.Count = 0 Then
                    oRng.Hyperlinks.Add oRng, sLink, , , sName
                    Exit Do
                End If
            Loop
        End With
    Next i
lbl_Exit:
    Exit Sub
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