VBA - Read Cell Value from Ms Word Table

Refs:
https://social.msdn.microsoft.com/Forums/en-US/864a7dac-27b5-4b66-8a73-f26c01444ef6/read-line-from-table-cell-for-vba-in-ms-word?forum=isvvba

https://stackoverflow.com/questions/24986753/vba-code-to-read-tables-from-word-document

(git-start)

	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

view raw VBA_readWordTable.bas hosted with ❤ by GitHub

(git-end)

---

---