Sub XLWordTable5()
Dim WrdApp As Object, FileStr As String
Dim WrdDoc As Object, TblCell As Variant
Dim Col As Integer, ARow As Integer, Ws As Worksheet
On Error GoTo ErFix
Application.ScreenUpdating = False
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = False
'********** change address to suit
FileStr = "D:\testfolder\tabletest.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Set Ws = ThisWorkbook.ActiveSheet
Col = ActiveCell.Column
ARow = ActiveCell.Row
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If TblCell.ColumnIndex = 2 Then
Ws.Cells(ARow, Col) = _
WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Ws.Cells(ARow, Col) = _
Application.WorksheetFunction.Clean(Ws.Cells(ARow, Col))
ARow = ARow + 1
End If
Next TblCell
below:
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=True
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
'MsgBox "Finished"
Application.ScreenUpdating = True
Exit Sub
ErFix:
On Error GoTo 0
Application.ScreenUpdating = True
MsgBox "error"
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub