我正在运行以下代码,以将Access数据库中的数据检索到Excel中。该代码大约需要1分钟才能执行。当前有8列的大约500条记录。我可以做些什么来修改我的代码以使其运行得更快?
Sub sync_Data()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim mysqlSt As String
Dim rowindex As Long
mysqlSt = "SELECT pbsclients.client, pbsclients.priority, pbsclients.source, pbsclients.lastcontact, pbsclients.result, pbsclients.nextsteps, pbsclients.attempts, pbsclients.notes FROM pbsclients; "
Set cn = New ADODB.Connection
With cn
.ConnectionString = con1
.Open
End With
rowindex = 2
Set rs = New ADODB.Recordset
rs.Open mysqlSt, cn, adOpenDynamic, adLockOptimistic
While Not rs.EOF
Sheet3.Cells(rowindex, 1) = rs!client
Sheet3.Cells(rowindex, 2) = rs!Priority
Sheet3.Cells(rowindex, 3) = rs!Source
Sheet3.Cells(rowindex, 4) = rs!lastcontact
Sheet3.Cells(rowindex, 5) = rs!result
Sheet3.Cells(rowindex, 6) = rs!nextsteps
Sheet3.Cells(rowindex, 7) = rs!attempts
Sheet3.Cells(rowindex, 8) = rs!Notes
rowindex = rowindex + 1
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Exit Sub
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
答案 0 :(得分:3)
这是我代码的有效版本,运行和检索大约需要2秒钟,而上面的代码需要45秒钟-1分钟。
Sub sync_Data()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim mysqlSt As String
Dim rowindex As Long
mysqlSt = "SELECT pbsclients.client, pbsclients.priority, pbsclients.source, pbsclients.lastcontact, pbsclients.result, pbsclients.nextsteps, pbsclients.attempts, pbsclients.notes FROM pbsclients WHERE Id <> 0 AND pbsclients.branch = '" & Sheet3.Range("Z1") & "'"
Set cn = New ADODB.Connection
With cn
.ConnectionString = con1
.Open
End With
rowindex = 2
Set rs = New ADODB.Recordset
rs.Open mysqlSt, cn, adOpenDynamic, adLockOptimistic
Do While Not rs.EOF
Sheet3.Range("A2").CopyFromRecordset rs
Loop
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
Exit Sub
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub