Cubajz,
What have you tried? Like anyone else, you would have an easier time if you would roll up your sleeves and make some effort at writing code. This is not a free code writing service! Generally we come here in the spirit of helping those who are trying to learn VBA. Nevertheless, here is one way that might work:
Option Explicit
Private m_arrExcelContent As Variant
Sub DoIt()
Dim strWorkbook As String
Dim lngIndex As Long
Dim oRng As Range
Dim oTbl As Table, oCell As Cell
strWorkbook = ThisDocument.Path & "\Book1.xlsx" 'Change to suit your actual Excel path.
If Dir(strWorkbook) = "" Then
MsgBox "Cannot find the designated workbook: " & strWorkbook, vbExclamation
Exit Sub
End If
m_arrExcelContent = fcnExcelDataToArray(strWorkbook, , , False)
For Each oCell In ActiveDocument.Tables(1).Range.Cells
Set oRng = oCell.Range
With oRng.Find
.Font.ColorIndex = wdRed
.MatchWildcards = True
If .Execute Then
For lngIndex = 0 To UBound(m_arrExcelContent, 2)
If InStr(m_arrExcelContent(0, lngIndex), Trim(oRng.Text)) > 0 Then
With oCell
.Range.Text = m_arrExcelContent(0, lngIndex)
.Range.Font.ColorIndex = wdAuto
End With
Exit For
End If
Next
End If
End With
Next
lbl_Exit:
Exit Sub
End Sub
Private Function fcnExcelDataToArray(strWorkbook As String, _
Optional strRange As String = "Sheet1", _
Optional bIsSheet As Boolean = True, _
Optional bHeaderRow As Boolean = True) As Variant
'Default parameters include "Sheet1" as the named sheet, range of the full named sheet and a header row is used.
Dim oRS As Object, oConn As Object
Dim lngRows As Long
Dim strHeaderYES_NO As String
strHeaderYES_NO = "YES"
If Not bHeaderRow Then strHeaderYES_NO = "NO"
If bIsSheet Then strRange = strRange & "$]" Else strRange = strRange & "]"
Set oConn = CreateObject("ADODB.Connection")
oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
Set oRS = CreateObject("ADODB.Recordset")
oRS.Open "SELECT * FROM [" & strRange, oConn, 2, 1
With oRS
.MoveLast
lngRows = .RecordCount
.MoveFirst
End With
fcnExcelDataToArray = oRS.GetRows(lngRows)
lbl_Exit:
If oRS.State = 1 Then oRS.Close
Set oRS = Nothing
If oConn.State = 1 Then oConn.Close
Set oConn = Nothing
Exit Function
End Function