To find word in Microsoft Word Table and copy Offsets to Excel Cells

[johngalvin]

Hello Paul,

Thanks for your message.

I adapted the code as following:
Unfortunately the cell A1 remains blank, so no Output, looked for sensitiveness of the text and of the code, all seems fine. I even tried on other Excel cell, but still blank. Even created a New Word Document in which I typed some random text then the Table in which I put the SearchWord "Fruits", and on the next Column "Apples", but still the cell remained blank, no output.

Dim SearchWord As String
SearchWord = "Fruits"
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
    'loop through table cells
    For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
         If InStr(TblCell.Range, SearchWord) Then
             Sheets("Sheet1").Range("A" & 1) = Split(WrdDoc.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1), vbCr, 0)
         End If
     Next TblCell
Next Cnt

If I put back the outdated code, the cell A1 would be filled with Apples[Symbol] and after like 10 seconds the [Symbol] would disappear, but there must be a way to do it in 1 step such as copying the text directly without Symbol

Dim SearchWord AsString
SearchWord ="Fruits"
For Cnt =1To WrdApp.ActiveDocument.Tables.Count
    'loop through table cells
    ForEach TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
        If InStr(TblCell.Range, SearchWord)Then
            'remove pilcrow
            Sheets(Sheet1").Range("A" & 1) = WrdApp.ActiveDocument.Tables(Cnt).Cell(TblCell.RowIndex, TblCell.ColumnIndex + 1)
            Sheets("Sheet1").Range("A" & 1) = Application.WorksheetFunction.Clean(Sheets("Sheet1").Range("A" & 1))
        End If
    Next TblCell
Next Cnt