请教各位大神,如何将excel中的表格数据自动存入ACCESS中,可随时刷新数据

用VBA编程实现比如这个,加个保存和刷新功能,存入Access数据库中
2025-01-27 12:55:34
推荐回答(1个)
回答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