Sub TextFindAndHyperlink()

    Dim query As String
    Dim SearchRange As Range
    Dim SearchText As String
    Dim WebAddress As String
    
    query = InputBox("Texts to replace as hyperlinks")
        If Not query = vbNullString Then
    
    Set SearchRange = ActiveDocument.Range
    SearchText = Replace(query, " ", "+")
    
    WebAddress = InputBox("Please paste the hyperlink")
    If Not WebAddress = vbNullString Then
    
    With SearchRange.Find
        Do While .Execute(SearchText, , True, , , , True) = True
            With SearchRange
                .Hyperlinks.Add SearchRange, WebAddress
            End With
            SearchRange.Collapse wdCollapseEnd
        Loop
    
    MsgBox ("The hyperlink is added to the text")
        
    End With
    
    End If
    End If
    
End Sub

Option Explicit

Const strWorkbook As String = "E:\Path\Example.xlsx"        'The path of the workbook
Const strSheet As String = "Sheet1"        'The name of the worksheet

Sub AddHLinks(oDoc As Document)
Dim Arr() As Variant
Dim i As Long
Dim oRng As Range
Dim sFindText As String
Dim sReplaceText As String
    Arr = xlFillArray(strWorkbook, strSheet)
    For i = 0 To UBound(Arr, 2)
        sFindText = Arr(0, i)
        sReplaceText = Arr(1, i)
        Set oRng = oDoc.Range
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(findText:=sFindText, _
                              MatchWholeWord:=True, _
                              Forward:=True, _
                              Wrap:=wdFindStop) = True
                oRng.Hyperlinks.Add oRng, sReplaceText
                oRng.End = oRng.End + 1
                oRng.Collapse wdCollapseEnd
                DoEvents
            Loop
        End With
    Next
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

Sub Macro1()
AddHLinks ActiveDocument

End Sub

Option Explicit

Private strWorkbook As String
Private strSheet As String

Sub Macro1()
strWorkbook = BrowseForFile("Select Workbook", True)
strSheet = InputBox("Enter worksheet name", "Worksheet", "Sheet1")
AddHLinks ActiveDocument, strWorkbook, strSheet
End Sub

Sub AddHLinks(oDoc As Document, strWorkbook As String, strSheet As String)

'etc