Option Explicit
Const strWorkbook As String = "U:\VBA Word Automation\Excel Test Sheet.xlsx"
Const strSheet As String = "Sheet1"        'The name of the worksheet

Sub Macro1()
'look for the value in the first column and return the value in the sixth column
Dim strResult As String
    strResult = GetValue("The value to find", 6)
    FillBM "bookmarkname", strResult 'fill the named bookmark with the value
lbl_Exit:
    Exit Sub
End Sub

Private Function GetValue(strKey As String, lngColumn As Long) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 08 May 2017
Dim Arr() As Variant
Dim iCols As Long
Dim strValue As String
Dim strID As String
    Arr = xlFillArray(strWorkbook, strSheet)
    For iCols = 0 To UBound(Arr, 2)
        strID = Arr(0, iCols)    'The first column
        strValue = Arr(lngColumn - 1, iCols)
        If strID = strKey Then
            GetValue = strValue
            Exit For
        End If
    Next iCols
lbl_Exit:
    Exit Function
End Function

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - Last updated - 08 May 2017

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=YES"";"

    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

Private Sub FillBM(strBMName As String, strValue As String)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strBMName).Range
        oRng.Text = strValue
        oRng.Bookmarks.Add strBMName
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub