|
楼主 |
发表于 2016-12-7 11:46
|
显示全部楼层
本帖最后由 my.excel 于 2016-12-7 15:34 编辑
Sub 导入Access()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'=====================================================================================================
'创建数据库连接
Dim Ecnn, Acnn As Object, Rst As Object
Set Acnn = CreateObject("ADODB.Connection") '链接access
Set Rst = CreateObject("ADODB.Recordset")
Dim i As Integer, exPath, acPath, acTable As String
exPath = ThisWorkbook.Path & "\订单.xlsx" '设置工作簿的完整路径和名称
acPath = ThisWorkbook.Path & "\数据库.accdb"
acTable = "订单"
Dim SQL As String
'======================================================================================================
Acnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & acPath '连接数据库access
'设置SQL查询语句>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
SQL = "select a.* from [Excel 12.0;Database=" & exPath & "].[订单$" & Range("a1").CurrentRegion.Address(0, 0) _
& "] a left join 订单 b on a.id = b.id where b.id is null"
Set Rst = New ADODB.Recordset
Rst.Open SQL, Acnn, 1, 3
'写入 数据到 access====================================================================================
If Rst.RecordCount > 0 Then '如果工作表中含有数据库不存在记录
SQL = "insert into " & 订单 & " " & SQL '插入新记录SQL语句
Acnn.Execute SQL
MsgBox Rst.RecordCount & "行数据已经添加到数据库!", vbInformation, "添加数据"
Else
MsgBox "工作表的数据数据库中已经存在。", vbInformation, "添加数据失败"
End If
'======================================================================================================
'数据录入到Excel
With ThisWorkbook.Sheets("监视器")
.Cells.Clear
For i = 0 To Rst.fields.Count - 1 '填写标题
.Cells(1, i + 1) = Rst.fields(i).Name
Next i
.Range("A2").CopyFromRecordset Rst
.Cells.EntireColumn.AutoFit '自动调整列宽
'.Cells.EntireColumn.AutoFit '自动调整列宽
End With
Rst.Close '关闭数据库连接
Acnn.Close
Set Acnn = Nothing
Set Rst = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
这段代码 有时导入成功,有时 在有新数据时 导入不成功,红色字体处发现问题。。 |
|