ADO+Access更新、插入速度优化

zhongchangliang

Sub update()
'=======================================================================
'1、ID不为空表示数据库中已有对应数据，对这部分数据只更新字段值
'2、ID为空表示表格内新增的数据，直接上传数据到数据库
'=======================================================================
Dim con, rs, SQL$, i%, r%, c%
Dim insertRow As Integer '记录无ID的数据行（插入）
Dim updateRow As Integer '记录有ID的数据行（更新）
Dim updateSQL, insertSQL
If Range("A1").CurrentRegion.Rows.Count = 2 Then Exit Sub '如果工作表只有两行数据，退出、不执行
myPath = ThisWorkbook.Path & "\kanban.accdb"
myTable = "kanban"
If Range("A3") <> "" Then
r = Range("A" & Rows.Count).End(3).Row
For c = 2 To 18
updateSQL = updateSQL & "a.[" & Cells(2, c) & "]=b.[" & Cells(2, c) & "],"
Next
For c = 21 To 28
updateSQL = updateSQL & "a.[" & Cells(2, c) & "]=b.[" & Cells(2, c) & "],"
Next
updateSQL = VBA.Left(updateSQL, VBA.Len(updateSQL) - 1)
updateSQL = "update " & myTable & " a,[Excel 12.0;imex=0;Database=" & ActiveWorkbook.FullName & "].[看板汇总$A2:AB" & r & "] b set " & updateSQL & " where a.ID=b.ID"
End If
'1）引用ADO对象，以下是后期绑定的方式
Set con = CreateObject("adodb.connection") '建立ADO连接对象
Set rs = CreateObject("adodb.recordset") '建立ADO记录集对象

'3）建立连接
On Error GoTo errmsg
con.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & myPath
con.Execute updateSQL
' MsgBox "数据已更新到数据库！", vbInformation, "更新数据"
con.Close
Set con = Nothing
Exit Sub
errmsg:
MsgBox Err.Description, , "错误报告"
End Sub

Sub AddNew()
Dim lR, uR '记录新增行行号
If Range("A1").CurrentRegion.Rows.Count = 2 Then Exit Sub
lR = Range("A" & Rows.Count).End(3).Row
uR = Range("B" & Rows.Count).End(3).Row
If uR < 3 Then Exit Sub
r = Sheets("看板汇总").Range("B" & Rows.Count).End(3).Row
myPath = ThisWorkbook.Path & "\kanban.accdb"
myTable = "kanban"
'构造SQL
For c = 2 To 18
insertSQL = insertSQL & "[" & Cells(2, c) & "],"
Next
For c = 21 To 28
insertSQL = insertSQL & "[" & Cells(2, c) & "],"
Next
insertSQL = VBA.Left(insertSQL, VBA.Len(insertSQL) - 1)
insertSQL = "insert into " & myTable & " select " & insertSQL & " from [Excel 12.0;Database=" & ActiveWorkbook.FullName & "].[看板汇总$A2:AB" & r & "] where ID is null"
Debug.Print insertSQL
'1）引用ADO对象，以下是后期绑定的方式
Set con = CreateObject("adodb.connection") '建立ADO连接对象
Set rs = CreateObject("adodb.recordset") '建立ADO记录集对象
'3）建立连接
On Error GoTo errmsg
con.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & myPath
con.Execute insertSQL
' MsgBox "数据已添加到数据库！", vbInformation, "添加数据"
con.Close
Set con = Nothing
Exit Sub
errmsg:
MsgBox Err.Description, , "错误报告"
End Sub

以上两段代码：
过程 update 向数据库更新 看板汇总 中有ID的数据
过程 AddNew 向数据库插入 看板汇总 中ID为空的数据

问题：
看板汇总中数据比较少时速度挺快的，但是数据达到1万行左右时速度就特别慢，会导致Excel假死，哪位老师有办法帮我优化一下？

zhongchangliang

1. Sub update()
   
2. '=======================================================================
   
3. '1、ID不为空表示数据库中已有对应数据，对这部分数据只更新字段值
   
4. '2、ID为空表示表格内新增的数据，直接上传数据到数据库
   
5. '=======================================================================
   
6. Dim con, rs, SQL$, i%, r%, c%
   
7. Dim insertRow As Integer '记录无ID的数据行（插入）
   
8. Dim updateRow As Integer '记录有ID的数据行（更新）
   
9. Dim updateSQL, insertSQL
   
10. If Range("A1").CurrentRegion.Rows.Count = 2 Then Exit Sub '如果工作表只有两行数据，退出、不执行
    
11. myPath = ThisWorkbook.Path & "\kanban.accdb"
    
12. myTable = "kanban"
    
13. If Range("A3") <> "" Then
    
14. r = Range("A" & Rows.Count).End(3).Row
    
15. For c = 2 To 18
    
16. updateSQL = updateSQL & "a.[" & Cells(2, c) & "]=b.[" & Cells(2, c) & "],"
    
17. Next
    
18. For c = 21 To 28
    
19. updateSQL = updateSQL & "a.[" & Cells(2, c) & "]=b.[" & Cells(2, c) & "],"
    
20. Next
    
21. updateSQL = VBA.Left(updateSQL, VBA.Len(updateSQL) - 1)
    
22. updateSQL = "update " & myTable & " a,[Excel 12.0;imex=0;Database=" & ActiveWorkbook.FullName & "].[看板汇总$A2:AB" & r & "] b set " & updateSQL & " where a.ID=b.ID"
    
23. End If
    
24. '1）引用ADO对象，以下是后期绑定的方式
    
25. Set con = CreateObject("adodb.connection") '建立ADO连接对象
    
26. Set rs = CreateObject("adodb.recordset") '建立ADO记录集对象
    
27. 
    
28. '3）建立连接
    
29. On Error GoTo errmsg
    
30. con.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & myPath
    
31. con.Execute updateSQL
    
32. ' MsgBox "数据已更新到数据库！", vbInformation, "更新数据"
    
33. con.Close
    
34. Set con = Nothing
    
35. Exit Sub
    
36. errmsg:
    
37. MsgBox Err.Description, , "错误报告"
    
38. End Sub

复制代码

zhongchangliang

1. Sub AddNew()
   
2. Dim lR, uR '记录新增行行号
   
3. If Range("A1").CurrentRegion.Rows.Count = 2 Then Exit Sub
   
4. lR = Range("A" & Rows.Count).End(3).Row
   
5. uR = Range("B" & Rows.Count).End(3).Row
   
6. If uR < 3 Then Exit Sub
   
7. r = Sheets("看板汇总").Range("B" & Rows.Count).End(3).Row
   
8. myPath = ThisWorkbook.Path & "\kanban.accdb"
   
9. myTable = "kanban"
   
10. '构造SQL
    
11. For c = 2 To 18
    
12. insertSQL = insertSQL & "[" & Cells(2, c) & "],"
    
13. Next
    
14. For c = 21 To 28
    
15. insertSQL = insertSQL & "[" & Cells(2, c) & "],"
    
16. Next
    
17. insertSQL = VBA.Left(insertSQL, VBA.Len(insertSQL) - 1)
    
18. insertSQL = "insert into " & myTable & " select " & insertSQL & " from [Excel 12.0;Database=" & ActiveWorkbook.FullName & "].[看板汇总$A2:AB" & r & "] where ID is null"
    
19. Debug.Print insertSQL
    
20. '1）引用ADO对象，以下是后期绑定的方式
    
21. Set con = CreateObject("adodb.connection") '建立ADO连接对象
    
22. Set rs = CreateObject("adodb.recordset") '建立ADO记录集对象
    
23. '3）建立连接
    
24. On Error GoTo errmsg
    
25. con.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & myPath
    
26. con.Execute insertSQL
    
27. ' MsgBox "数据已添加到数据库！", vbInformation, "添加数据"
    
28. con.Close
    
29. Set con = Nothing
    
30. Exit Sub
    
31. errmsg:
    
32. MsgBox Err.Description, , "错误报告"
    
33. End Sub

复制代码

zhongchangliang

经测试是过程 update 中的 update语句执行慢

1. update kanban a,[Excel 12.0;imex=0;Database=C:\Users\Administrator\Desktop\看板系统开发\看板汇总.xlsm].[看板汇总$A2:AB35296] b set a.[生产任务号]=b.[生产任务号],a.[整机代码]=b.[整机代码],a.[规格型号]=b.[规格型号],a.[数量]=b.[数量],a.[销售员]=b.[销售员],a.[出货日期/总装完成日期]=b.[出货日期/总装完成日期],a.[PMC调整后原出货日期]=b.[PMC调整后原出货日期],a.[下达车间日期]=b.[下达车间日期],a.[原计划配料时间]=b.[原计划配料时间],a.[PMC调整总装配料日期]=b.[PMC调整总装配料日期],a.[总装物料到料日期]=b.[总装物料到料日期],a.[总装仓库实际配料日期]=b.[总装仓库实际配料日期],a.[仓库总装配料异常]=b.[仓库总装配料异常],a.[总装车间投入时间]=b.[总装车间投入时间],a.[总装完成数量]=b.[总装完成数量],a.[总装完成时间]=b.[总装完成时间],a.[总装异常]=b.[总装异常],a.[计划部相关备注说明]=b.[计划部相关备注说明],a.[责任部门]=b.[责任部门],a.[插单]=b.[插单],a.[提前订单]=b.[提前订单],a.[任务书登记日期]=b.[任务书登记日期],a.[电机类别]=b.[电机类别],a.[排产计划]=b.[排产计划],a.[销售发货计划日期]=b.[销售发货计划日期] where a.ID=b.ID
   

复制代码

单独执行过程AddNew还是很快的，不知道这个update语句还能优化吗

zpy2

imex=0我记得是汇入，汇出可能是 imex=1;汇总$A2:AB35296,每次都要更新这么多行列的数据吗？

ivccav

你的数据库至少要版本14.0，我的2007没法玩。看了一下代码，建议你：

在update中去掉Set con = Nothing，并把con定义为公共变量，这样每次更新时，无需从头新建连接。

建立连接通信需要消耗很多资源，会影响速度。每次update完成，只需close，下车调用open就行了。

可以用con.state=adStateOpen看是不是断开，如果关闭，open之。

zhongchangliang

ivccav 发表于 2018-5-9 20:39
你的数据库至少要版本14.0，我的2007没法玩。看了一下代码，建议你：

在update中去掉Set con = Nothin ...

谢谢，不过我的表格是要分发给多人使用的，这样做会不会有影响？

zhongchangliang

zpy2 发表于 2018-5-9 20:22
imex=0我记得是汇入，汇出可能是 imex=1;汇总$A2:AB35296,每次都要更新这么多行列的数据吗？

目前已经有1万行数据，大概每年能增加1万行

ivccav

zhongchangliang 发表于 2018-5-9 21:35
谢谢，不过我的表格是要分发给多人使用的，这样做会不会有影响？

不会有影响。你的表格相当于客户端，每个客户端都可以连接数据库。每次使用完都应该断开，再用时再打开。

你的更新和添加都应该使用公共连接对象。大致的代码如下，仅供参考：

1. Public conn As ADODB.Connection
   
2. 
   
3. Sub pubconn()
   
4.     Dim strConnStr As String
   
5.     strConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=d:\myFolder\myAccessFile.accdb;"
   
6.     Set conn = New ADODB.Connection
   
7.     conn.Open
   
8.     conn.Close
   
9. End Sub
   
10. 
    
11. Sub test()
    
12. If conn Is Nothing Then Call pubconn
    
13. If Not conn.State = adStateOpen Then conn.Open
    
14. '......
    
15. conn.Close
    
16. End Sub
    

复制代码

小鸡无用

where ID is null 非常耗费资源。建议 ID 值默认为0 where ID =0 。
update 不要直接使用单元格，全表存入数组，用循环方式逐条更新。
字段值预先判定格式 isnumeric(),isdate(),len()>0空值直接跳过,set 字段名=字段值