本程序可以从Excel中读取数据到Access数据库中。Option ExplicitPrivate Sub cmdLoad_Click() Dim excel_app As Object Dim excel_sheet As Object Dim db As Database Dim new_value As String Dim row As Integer Screen.MousePointer = vbHourglass DoEvents '建立Excel application对象 Set excel_app = CreateObject("Excel.Application") '打开指定的工作薄 excel_app.Workbooks.Open FileName:=txtExcelFile.Text '判断版本 If Val(excel_app.Application.Version) >= 8 Then Set excel_sheet = excel_app.ActiveSheet Else Set excel_sheet = excel_app End If '打开Access数据库 Set db = OpenDatabase(txtAccessFile.Text) '删除表中原有记录 db.Execute "delete from TestValues" ' 从Excel工作表中获取数据并插入到数据库的TestValues表中 row = 1 Do
' 得到工作表中的值 new_value = Trim$(excel_sheet.Cells(row, 1)) '如果某行空,则停止 If Len(new_value) = 0 Then Exit Do '将获取的值插入到数据库的表TestValues中 db.Execute "INSERT INTO TestValues VALUES (" & new_value & ")" '下一行 row = row + 1 Loop ' 关闭数据库 db.Close '释放内存 Set db = Nothing '关闭工作表,不重新保存 excel_app.ActiveWorkbook.Close False '关闭Excel excel_app.Quit '释放内存 Set excel_sheet = Nothing Set excel_app = Nothing '鼠标指针形状还原 Screen.MousePointer = vbDefault '弹出提示框 MsgBox "Copied " & Format$(row - 1) & " values.", , "Finished" End SubPrivate Sub Form_Load() '初始化文件路径 Dim file_path As String file_path = App.Path If Right$(file_path, 1) <> "\" Then file_path = file_path & "\" txtExcelFile.Text = file_path & "XlsToMdb.xls" txtAccessFile.Text = file_path & "XlsToMdb.mdb" End Sub
Dim excel_app As Object
Dim excel_sheet As Object
Dim db As Database
Dim new_value As String
Dim row As Integer
Screen.MousePointer = vbHourglass
DoEvents
'建立Excel application对象
Set excel_app = CreateObject("Excel.Application")
'打开指定的工作薄
excel_app.Workbooks.Open FileName:=txtExcelFile.Text
'判断版本
If Val(excel_app.Application.Version) >= 8 Then
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If
'打开Access数据库
Set db = OpenDatabase(txtAccessFile.Text)
'删除表中原有记录
db.Execute "delete from TestValues"
' 从Excel工作表中获取数据并插入到数据库的TestValues表中
row = 1
Do
new_value = Trim$(excel_sheet.Cells(row, 1))
'如果某行空,则停止
If Len(new_value) = 0 Then Exit Do
'将获取的值插入到数据库的表TestValues中
db.Execute "INSERT INTO TestValues VALUES (" & new_value & ")"
'下一行
row = row + 1
Loop
' 关闭数据库
db.Close
'释放内存
Set db = Nothing
'关闭工作表,不重新保存
excel_app.ActiveWorkbook.Close False
'关闭Excel
excel_app.Quit
'释放内存
Set excel_sheet = Nothing
Set excel_app = Nothing
'鼠标指针形状还原
Screen.MousePointer = vbDefault
'弹出提示框
MsgBox "Copied " & Format$(row - 1) & " values.", , "Finished"
End SubPrivate Sub Form_Load()
'初始化文件路径
Dim file_path As String
file_path = App.Path
If Right$(file_path, 1) <> "\" Then file_path = file_path & "\"
txtExcelFile.Text = file_path & "XlsToMdb.xls"
txtAccessFile.Text = file_path & "XlsToMdb.mdb"
End Sub