Option Explicit ' Helps to ensure your code is good

Sub Runme()
'*** Run this procedure
'Require Reference to Microsoft Word 16.0 Object Library
'This code will work for a standard word document with at least one 2 column table

Dim wdApp As Word.Application
Dim WdDoc As Word.Document
Dim wdTable As Word.Table
Dim i As Integer
    On Error GoTo ErrHandler
    
    Set wdApp = CreateObject("Word.Application")   ' Open Word document
    Set WdDoc = wdApp.Documents.Open(OpenFile)    ' Open the word document - Will run the function above
    Set wdTable = WdDoc.Tables(1)                  ' Reference table by number
    ' **** Activate if you want to see the Doc.  otherwise, leave outta sight for speed.
    'wrdApp.Visible = True
    'wrdApp.Activate
    
    'Copies Cell to Excel by looping through each row in the word document.
    'Cell(i,1) is first column, Cell(i,2) is second column.
    With wdTable
        For i = 1 To .Rows.Count
            'Sheet1 (Excel) = Word table cell
            Sheet1.Cells(i, 1).Value = CorrectCellString(.Cell(i, 1).Range.Text)
            Sheet1.Cells(i, 2).Value = CorrectCellString(.Cell(i, 2).Range.Text)
        Next i
    End With
    Sheet1.Cells(1, 1).Select ' Return cell selection to row 1, column 1
    
Finishup:
    'Close Doc and Release
    WdDoc.Close
    wdApp.Quit
    Set wdApp = Nothing
    Set WdDoc = Nothing
    Set wdTable = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Number & vbCrLf & Err.Description ' Tell me what went wronog
    GoTo Finishup
End Sub

Function CorrectCellString(StrString As String) As String
'Purpose:  correct the cell string from word - removes paragraph markers, etc
    CorrectCellString = Left(StrString, Len(StrString) - 2)
End Function

Function OpenFile() As String
'Opens Word document from user selection
Dim fd As Office.FileDialog
Dim strFile As String
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add "Word Files", "*.docx", 1
        .Title = "Choose an Excel file"
        .AllowMultiSelect = False
        .InitialFileName = "C:\VBA Folder"
        If .Show = True Then
            strFile = .SelectedItems(1)
            OpenFile = strFile
        End If
    End With
End Function