Dim wdTable As Table, WdRange As Range
Set WdRange = ActiveDocument.Content
WdRange.Find.ClearFormatting
WdRange.Find.Text = "456456"
WdRange.Find.Execute
Set wdTable = WdRange.Tables(1)
MsgBox wdTable.Cell(1, 1)

End Sub

Set wdTable = WdRange.Tables(1)

i = 2 'предполагаемый минимальный номер таблицы
Set WdTable = ActiveDocument.Content.Tables(i)

While WdTable.Cell(1, 2).Range.text <> "уникальный текст в данной ячейке" & vbCr & Chr(7)
MsgBox WdTable.Cell(1, 2)
i = i + 1
Set WdTable = ActiveDocument.Content.Tables(i)
Wend