VBA Read Cell Value of MS Word Table

VBA_readWordTable.bas

Option Explicit
Public Sub read_word()
    Dim wa As Word.Application
    Dim wd As Word.Document
    Dim wdtable As Word.Table
    
    Dim wdFileName    As Variant
    Dim TableNo       As Integer  'number of tables in Word doc
    Dim iTable        As Integer  'table number index
    Dim iRow          As Long     'row index in Excel
    Dim iCol          As Integer  'column index in Excel
   
    Dim strCellText As String
    Dim strCellTextLines As New Collection
    Dim rtext As Variant
    Dim vv As Variant
    
    wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _
     "Browse for file containing table to be imported")
    
    If wdFileName = False Then Exit Sub
    Set wd = GetObject(wdFileName)
    
    With wd
      TableNo = wd.Tables.Count
      If TableNo = 0 Then
         MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
      ElseIf TableNo > 1 Then
         TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & _
         "Enter table number of table to import", "Import Word Table", "1")
      End If
      
      Debug.Print "Test 1-------------------------------------"
      With .Tables(TableNo)
         'copy cell contents from Word table cells to Excel cells
         For iRow = 1 To .Rows.Count
            rtext = ""
            For iCol = 1 To .Columns.Count
               ''Cells(iRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
               rtext = rtext & WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) & " "
            Next iCol
            Debug.Print rtext
         Next iRow
      End With
   End With
   
   ''Above function already run OK, but below is another test reading...
   Debug.Print "Test 2-------------------------------------"
   For Each wdtable In wd.Tables
        With wdtable
            Debug.Print "Table :" & wdtable.Title & ":" & wdtable.ID & ":" & wdtable.Rows.Count
            For iRow = 1 To .Rows.Count
                rtext = ""
                For iCol = 1 To .Columns.Count
                    strCellText = .Cell(iRow, iCol).Range.Text
                    Set strCellTextLines = ParseLines(strCellText)
                    ''''Debug.Print "Lines of text found = " & CStr(strCellTextLines.Count)
                    For Each vv In strCellTextLines
                        rtext = rtext & vv & " "
                    Next vv
                Next iCol
                Debug.Print rtext
            Next iRow
            
        End With
   Next
   
   Set strCellTextLines = Nothing
   Set wd = Nothing
    
End Sub
Private Function ParseLines(tStr As String) As Collection
    Dim tColl As New Collection, tptr As Integer, tlastptr As Integer, tCurrStr As String
    tlastptr = 1

    With tColl
        Do
            tptr = InStr(tlastptr, tStr, Chr(13))
            If tptr = 0 Then Exit Do

            tCurrStr = Mid(tStr, tlastptr, tptr - tlastptr)
            tColl.Add tCurrStr

            tlastptr = tptr + 1
        Loop
    End With

    Set ParseLines = tColl
End Function