Sub CallEx3()

    Dim objExcel As New Excel.Application
    Dim exWb As Excel.Workbook
    Dim oRng As Excel.Range
    Dim oSheet As Excel.Worksheet
    Dim LastRow As Long
    
    Set exWb = objExcel.Workbooks.Open("U:\VBA Word Automation\Excel Test Sheet.xlsx")
    
    For Each oSheet In objExcel.ActiveWorkbook.Worksheets
            LastRow = Cells(Rows.Count, 1).End(xlUp).Row
             For i = 2 To LastRow
                 ThisValue = Cells(i, 1).Value
                           If ThisValue = TextBox1.Text Then
                          Cells(i, 6).Copy
                               WordApp.Selection.PasteSpecial.FillBM Link:=False,    DataType:=wdPasteText, _
                             Placement:="bmDT", DisplayAsIcon:=False                  
                 End If
            Next i

    Next oSheet


    exWb.Close

    Set exWb = Nothing
    Set objExcel = Nothing
    Set oRng = Nothing
    
    Exit Sub
   
End Sub

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

Sub Macro1()
'look for the value in the first column and return the value in the sixth column
Dim strResult As String
Dim strValue As String
    strValue = InputBox("Enter the value to find")
    If strValue = "" Then
        MsgBox "No value entered or user cancelled"
        GoTo lbl_Exit
    End If
    strResult = GetValue(strValue, 6)
    FillBM "bookmarkname", strResult    'fill the named bookmark with the value
lbl_Exit:
    Exit Sub
End Sub