Importing tables from MS Word

Question

I'm faced with the task of taking 2000+ lease abstracts in several large Word 95 files and moving certain data from them into a comma delimited text file - something suitable for eventual upload into Access or Excel format.

Answer

From: Shamil Salakhetdinov <shamil@marta.darts.spb.ru>
To: <accessd@mtgroup.com>
Subject: Re: [accessd] OT - Extracting Data From Word 95 (!!!)
Date: 24 April 1999 0:00

Doris,

MS Word doc's tables are stored in Tables collection - you can for ... each this collection to get the data from each table into e.g. MS Access table(s). Enclosed you'll find the code I posted to Access-L in Nov 1998 which gets MSWord doc tables into MSAccess tables. I hope you'll find the way to adapt it to your case.

HTH,
Shamil

P.S. The code:

Public Function smsMSWordTablesImport(ByVal vstrDocFullPath As String, _
                                      ByRef rdbs As Database)
'*+
' Written 30/11/98 by Shamil Salakhetdinov, e-mail:
shamil@marta.darts.spb.ru
'
' Purpose: Import all the tables of an MS Word doc into MS Access tables
'
' Note:    This sample code is just a working template...
'          It assumes that the first row of each table has column name...
'
'*-

  Dim wapp As Word.Application
  Dim wdoc As Word.Document
  Dim wtbl As Word.Table
  Dim wtblCol As Word.Column
  Dim wtblRow As Word.Row
  Dim wtblCell As Word.Cell

  Dim strDocName As String
  Dim intPos As Integer
  Dim tdf As TableDef
  Dim strTblName As String
  Dim fld As Field
  Dim rst As Recordset
  Dim intIdx As Integer
  Dim intColNo As Integer
  Dim intRowNo As Integer
  Dim strColNo As String
  Dim varValue As Variant

  Set wapp = New Word.Application
  Set wdoc = wapp.Documents.Open(vstrDocFullPath, , True)
  strDocName = wdoc.Name
  intPos = InStr(1, strDocName, ".")
  If intPos > 1 Then
    strDocName = Mid(strDocName, 1, intPos - 1)
  End If

  intIdx = 1
  For Each wtbl In wdoc.Tables
    strTblName = strDocName & "_Tbl" & Format(intIdx, "000")
    On Error Resume Next
    ' it deletes any tables with the same name as in strTblName
    rdbs.TableDefs.Delete strTblName
    rdbs.TableDefs.Refresh
    On Error GoTo 0

    Set tdf = rdbs.CreateTableDef(strTblName)
    For Each wtblCol In wtbl.Columns
      strColNo = wtblCol.Cells(1).Range.Text
      strColNo = Trim(Left(strColNo, Len(strColNo) - 2))
      Set fld = tdf.CreateField(strColNo, dbText, 255)
      tdf.Fields.Append fld
    Next

    rdbs.TableDefs.Append tdf
    rdbs.TableDefs.Refresh

    Set rst = rdbs.OpenRecordset(strTblName, dbOpenDynaset, dbAppendOnly)
    For Each wtblRow In wtbl.Rows
     If wtblRow.Cells(1).RowIndex > 1 Then
      rst.AddNew
       For Each wtblCell In wtblRow.Cells
        varValue = wtblCell.Range.Text
        If Not IsNull(varValue) Then
          If Len(varValue) <= 2 Then
            varValue = Null
          Else
            varValue = Left(varValue, Len(varValue) - 2)
          End If
        End If
        rst(wtblCell.ColumnIndex - 1) = varValue
       Next
      rst.Update
     End If
    Next
    rst.Close
    intIdx = intIdx + 1
  Next

  wdoc.Close
  wapp.Quit

  Set rst = Nothing
  Set tdf = Nothing

  Set wtblCell = Nothing
  Set wtblRow = Nothing
  Set wtblCol = Nothing
  Set wtbl = Nothing
  Set wdoc = Nothing
  Set wapp = Nothing
End Function