VBA execl将数据导入数据库

Sub 把Excel数据插入数据库中()

'*******************************************

'时间：2010-06-28

'作者：bengdeng

'功能：把当前工作表的数据增加到在程序文件同一目录下进销存表数据库中

'注意：要在工具/引用中引用microsoft activex date objects x.x

' 其中x.x为版本号，可能会因为你安装的office的版本不同而不同，本例引用了2.5版

'发布：http://www.excelba.com

'*******************************************

Dim conn As ADODB.Connection

Dim WN As String

Dim TableName As String

Dim sSql As String

Dim tStr As String

'数据库名，请自行修改，路径与当前工作簿在同一目录

WN = "进销存表.mdb"

'数据库的表名与当前工作表名一致

TableName = ActiveSheet.Name

Set conn = New ADODB.Connection

conn.ConnectionString = "Provider=Microsoft.Jet.Oledb.4.0" &_

"Extended Properties=Excel 8.0" &_

"Data Source=" &ThisWorkbook.Path &"\" &ActiveWorkbook.Name

conn.Open

If conn.State = adStateOpen Then

sSql = "Insert Into [DataBase=" &ActiveWorkbook.Path &"\" &WN &"]." &TableName &" Select * From [" &ActiveSheet.Name &"$]"

conn.Execute sSql

MsgBox "成功把数据插入到“" &TableName &"”中！", , "http://excelba.com"

conn.Close

End If

Set conn = Nothing

End Sub

1、首先为导入文件设置一个按钮：（更新数据）

2、为“更新数据”按钮添加执行代码：

Private Sub Command87_Click()

If MsgBox("请准备好导入的文件！", vbOKCancel, "打印确认") = 1 Then

Dim xdlj As String 'xdlj:相对路径

Dim dklj As String 'dklj:打开路径

dklj = od()

If Not (dklj = "") Then

xdlj = "SELECT 字段名称1,字段名称2,字段名称3," _

& " INTO  ACCESS中表名称 FROM [Excel 8.0Database=" & dklj & "].[Plan$] WHERE 对EXCEL的筛选条件（可以省略）"   '这句是最关键的

DoCmd.SetWarnings False   '关闭提示警告窗口

DoCmd.RunSQL xdlj '运行SQL

MsgBox "您于" & Now() & "更新数据成功！", vbInformation '人性化提示

End If

End If

End Sub

注意  OD（）  意思是open dialogue  我自己定义的函数，为了打开选择文件的会话框：

代码如下：

Public Function od() 'Opendialog

Dim f As FileDialog

Set f = Application.FileDialog(msoFileDialogFilePicker)

'f.Show

If f.Show = True Then

f.Filters.Clear

f.Filters.Add "Excel文件", "*.xls"

od = f.SelectedItems(1)

Else

MsgBox "您中途选择了取消！"

End If

End Function

4、最终效果：

excel中：

ACCESS中：

---