请教各位大神,如何将excel中的表格数据自动存入ACCESS中,可随时刷新数据 5
1个回答
展开全部
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
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
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询