Excel数据传入Access理容易些,这里给你Word数据传入Access的代码:
Sub TableToAccess()
'Created 2-18-99 by Helen Feddema
'Last modified 12-13-2001
On Error GoTo ErrorHandler
Dim strSiteName As String
Dim strIDName As String
Dim strIDValue As String
Dim strDBName As String
Dim DAO As New DAO.DBEngine
Dim dbs As Database
Dim rstOne As Recordset
Dim rstMany As Recordset
Dim wks As Workspace
Dim strDocsDir As String
Dim lngID As Long
Dim lngStartRows As Long
Dim lngRows As Long
'Pick up path to Documents folder from Registry
strDocsDir = System.PrivateProfileString("", _
"HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", _
"Personal")
strDBName = strDocsDir & "\Logons and IDs.mdb"
Debug.Print "DBName: " & strDBName
Set wks = DAO.Workspaces(0)
Set dbs = wks.OpenDatabase(strDBName)
Set rstOne = dbs.OpenRecordset("tblLogons")
Set rstMany = dbs.OpenRecordset("tblLogonValues")
Selection.HomeKey Unit:=wdStory
NextItem:
'Pick up site name from Heading 3 style
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 3")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
End With
Selection.Find.Execute
If Selection.Find.Found = False Then
GoTo ErrorHandlerExit
End If
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
strSiteName = Selection
Debug.Print "Site name: " & strSiteName
rstOne.AddNew
rstOne!SiteName = strSiteName
lngID = rstOne!ID
Debug.Print "ID: " & lngID
rstOne.Update
'Go to next table
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext, _
Count:=1, Name:=""
lngStartRows = Selection.Information(wdMaximumNumberOfRows)
'Select current cell
Selection.MoveRight Unit:=wdCell
Selection.MoveLeft Unit:=wdCell
AddValues:
If Selection.Type = wdSelectionIP Then GoTo NextItem
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'Save ID name and value to variables
strIDName = Selection
Debug.Print "ID name: " & strIDName
Selection.MoveRight Unit:=wdCell
strIDValue = Selection
Debug.Print "ID value: " & strIDValue
'Write ID name and value to Many table
With rstMany
.AddNew
!ID = lngID
!ItemName = strIDName
!ItemValue = strIDValue
.Update
End With
'Check whether still in table, and go to next heading if not
Selection.MoveRight Unit:=wdCell
lngRows = Selection.Information(wdMaximumNumberOfRows)
Debug.Print "Start rows: " & lngStartRows & vbCrLf & "Rows: " & lngRows
If lngRows = lngStartRows Then
If Selection.Information(wdWithInTable) = True Then
GoTo AddValues
Else
GoTo NextItem
End If
End If
ErrorHandlerExit:
rstOne.Close
rstMany.Close
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number & "; error message: " & Err.Description
Resume ErrorHandlerExit
End Sub