Option Explicit
Const strWorkbook As String = "C:\Path\WorkbookName.xlsx"        'The path of the workbook
Const strRange As String = "RangeName"

Private Function xlFillArray(strWorkbook As String, _
                             strRangeName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long
    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 [" & strRangeName & "]", 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 Test()
'Look for the value 'Al Gore' in the first column of the array
'And report the value in the second column
'Which here should report - 14132
Dim arr() As Variant
    arr = xlFillArray(strWorkbook, strRange)
    On Error GoTo lbl_Exit
    For iRows = 0 To UBound(arr, 1)
        sResult = arr(0, iRows)
        If sResult = "Al Gore" Then
            MsgBox arr(1, iRows)
        End If
    Next iRows
lbl_Exit:
    Exit Sub
End Sub

Sub Test()
    Dim f, xlWorkBook As Object
    Dim Nm As Variant
    Dim NewPath, xlNamedRange, MyText As String
    Dim Bmk() As String
    Dim x, j As Integer

    'Choose the Excel File
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Please Select A New File"
    f.AllowMultiSelect = False
    f.Filters.Clear
    f.Filters.Add "Microsoft Excel Files", "*.xls, *.xlsb, *.xlsm, *.xlsx" 'Limit to Excel Files Only

    If f.Show = -1 Then
        'NewPath = f.SelectedItems(1)
        'MsgBox "The New File Path is: " & NewPath
        Set xlWorkBook = GetObject(f.SelectedItems(1))
        
        'Put all Excel Named Ranges into an Array
        For Each Nm In xlWorkBook.Names
            xlNamedRange = Nm.Name

            If xlNamedRange = ActiveDocument.Bookmarks("Company_Name") Then
                'Selection.TypeText (MyText)
                MyText = "String you want to insert"
                'UpdateBM "Company_Name", MyText
            End If
        Next Nm
    Else 'user clicked cancel
        Exit Sub
    End If
    
    'Read all the Book Marks into an Array
    x = ActiveDocument.Bookmarks.Count
    ReDim Bmk(x)
    For j = 1 To x
        Bmk(j) = ActiveDocument.Bookmarks(j).Name
        UpdateBM ActiveDocument.Bookmarks(j).Name, ""
        ActiveDocument.Bookmarks(j).Range.InsertAfter "add this after"
    Next j
    
    ActiveDocument.Bookmarks.ShowHidden = True
    ActiveWindow.View.ShowBookmarks = False
    
End Sub


Sub UpdateBM(BookmarkToUpdate As String, TextToUse As String)
    Dim BMRange As Range
    Set BMRange = ActiveDocument.Bookmarks(BookmarkToUpdate).Range
    BMRange.Text = TextToUse
    ActiveDocument.Bookmarks.Add BookmarkToUpdate, BMRange
End Sub

Sub Test()
    Dim f, xlWorkBook As Object
    Dim Bm, Nm As Variant
    Dim Bmk, NmdRng, NmdValue As String
    Dim NewPath, MyText As String

    'Choose the Excel File
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    f.Title = "Please Select A New File"
    f.AllowMultiSelect = False
    f.Filters.Clear
    f.Filters.Add "Microsoft Excel Files", "*.xls, *.xlsb, *.xlsm, *.xlsx" 'Limit to Excel Files Only

    If f.Show = -1 Then
        'NewPath = f.SelectedItems(1)
        'MsgBox "The New File Path is: " & NewPath
        Set xlWorkBook = GetObject(f.SelectedItems(1))
    Else 'user clicked cancel
        Exit Sub
    End If
    
    For Each Bm In ActiveDocument.Bookmarks
        Bmk = Bm.Name
        'MsgBox Bm
             
        ' Check Each BookMark for a Matching NamedRanged in the Excel File
        For Each Nm In xlWorkBook.Names
        NmdRng = Nm.Name
        NmdValue = Nm.Value 'This currently wrong, gives the cell reference, not the value?
        
             If Bmk = NmdRng Then
                'MsgBox "Match Found with " & Bmk
                'MsgBox NmdValue
                MyText = "String you want to insert"
                'ActiveDocument.Bookmarks(Bmk).Range.InsertAfter MyText
                ActiveDocument.Bookmarks(Bmk).Range.InsertAfter NmdValue
                'UpdateBM Bmk, MyText
                 Exit For
             End If
        Next Nm
        
    Next Bm
    
    ActiveDocument.Bookmarks.ShowHidden = True
    ActiveWindow.View.ShowBookmarks = False
    
End Sub


Sub UpdateBM(BookmarkToUpdate As String, TextToUse As String)
    Dim BMRange As Range
    Set BMRange = ActiveDocument.Bookmarks(BookmarkToUpdate).Range
    BMRange.Text = TextToUse
    ActiveDocument.Bookmarks.Add BookmarkToUpdate, BMRange
End Sub