Option Explicit

Sub CopyText_from_Word_to_Excel()

On Error Resume Next
    ' Declare variables
    Dim xlWB1 As String
    Dim xlWB2 As String
    Dim xlSheet As String
    Dim EXL As Object
    Dim oDoc As Document
    Dim oRng As Range
    Dim Arr() As Variant
    
    ' Set the path to the Excel workbook to copy data from
    xlWB1 = "C:\Users\Excel file\list.xlsx"
    
    ' Show a file dialog box to select the Excel workbook to copy data to
    xlWB2 = BrowseForFile("Select Workbook", True)
    If xlWB2 = vbNullString Then Exit Sub
    
    ' Set the name of the worksheet to copy data to
    xlSheet = "Sheet1"
    
    ' Create an instance of Excel and open the target workbook
    Set EXL = CreateObject("Excel.Application")
    EXL.Visible = True
    EXL.Workbooks.Open xlWB2
    
    ' Get a reference to the active Word document and search for each value in the Excel workbook
    Set oDoc = ActiveDocument
    Set oRng = oDoc.Range
    Arr = xlFillArray(xlWB1, xlSheet)
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Name = "Times New Roman"
        .Font.Bold = True
        Dim ind As Long
        For ind = LBound(Arr, 2) To UBound(Arr, 2)
            .Text = Arr(1, ind)
            Do While .Execute()
                WriteToWorksheet xlWB2, xlSheet, oRng.Text
            Loop
        Next ind
    End With
End Sub

Public Function WriteToWorksheet(strWorkbook As String, _
                                  strRange As String, _
                                  strValues As String)
    ' Declare variables
    Dim ConnectionString As String
    Dim strSQL As String
    Dim CN As Object
    
    ' Set the connection string and SQL statement to write data to the worksheet
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    
    ' Open a connection to the workbook and execute the SQL statement
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString
    CN.Execute strSQL
    CN.Close
End Function

Public Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    ' Declare variables
    Dim fDialog As FileDialog
    
    ' Show a file dialog box to select a file
    On Error Resume Next
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            BrowseForFile = fDialog.SelectedItems.Item(1)
        End If
    End With
End Function

Public Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
    ' Declare variables
    Dim RS As Object
    Dim CN As Object
    Dim iRows As Long
    
    ' Set the connection string and SQL statement to read data from the worksheet
    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;IMEX=1"""
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1
    
    ' Get the data from the recordset and close the connection and recordset
    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    RS.Close
    CN.Close
End Function