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.
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
Copyright © 1999-2008 by Shamil Salakhetdinov. All rights reserved.