VB把excel数据插入access

Private Sub CommandButton1_Click()

Set Cnn = CreateObject("ADODB.Connection")

Set Rst = CreateObject("ADODB.Recordset")

Dim stPath As String

Dim strSQL As String

Dim aa As Variant

Dim i As Integer

Dim arrFid As Variant

aa = Timer

MsgBox "准备传数据到数据库，请稍等！", vbInformation, "温馨提示"

stPath = ThisWorkbook.Path & Application.PathSeparator & "人力资源管理系统.mdb"

Cnn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & stPath & ";Jet OLEDB:Database Password=" & "access"

Cnn.Execute "DELETE * FROM 车间计件工资数据库"

'删除所有纪录

strSQL = "Select * from 车间计件工资数据库"

Rst.Open strSQL, Cnn, 1, 3

arrFid = Array("prj_NO", "S_Exp", "S_X", "S_Y", "S_Deep", "E_Exp", "E_X", "E_Y")

With Sheets("综合线表")

For i = 2 To .Range("a65536").End(xlUp).Row '数组添加比单个添加快很多!

Rst.AddNew arrFid, Array(i - 2, Str(.Cells(i, 1)), Str(.Cells(i, 2)), Val(.Cells(i, 3)), Val(.Cells(i, 4)), Val(.Cells(i, 5)), Str(.Cells(i, 6)), Val(.Cells(i, 7)))

Next

End With

     Rst.Close: Set Rst = Nothing

     Cnn.Close: Set Cnn = Nothing

MsgBox "写入数据" & [a2].End(xlDown).Row - 1 & "行" & vbCrLf & "传输完毕：耗时" & Format(Timer - aa, "0.000") & "秒", vbInformation, "温馨提示"

Application.OnTime Now + TimeValue("00:50:00"), "chuanshu"

End Sub