[分享]VBA加快Excel數(shù)據(jù)導(dǎo)入速度

Benjamin_luk

ACCESS本身是有TransferSpreadsheet的功能將EXCEL表格數(shù)據(jù)導(dǎo)入ACCESS
但在此過程中,不能對錯誤進行判斷和處理.
本人在寫VBA代碼時,最初如下:
但速度明顯比TransferSpreadsheet慢很多:
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim rs As Recordset
Dim I As Double, J As Integer, n As Integer
Dim TargetR, stime, DataK
If Dir(filstr) <> "" Then
stime = Timer
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(filstr)
Set xlSheet = xlBook.Worksheets(1)
CurrentDb.Execute "Delete * from [1 庫存（MB52）]"
Set rs = CurrentDb.OpenRecordset("1 庫存（MB52）")
'MsgBox rs.RecordCount
xlApp.ScreenUpdating = False
With xlSheet
I = .Range("A1").End(xlDown).Row
Set TargetR = .Range("A1:I" & I)
xlApp.ScreenUpdating = True
End With
For J = 2 To I
rs.AddNew
rs.Fields(1) = TargetR(J, 1)
rs.Fields(2) = TargetR(J, 2)
rs.Fields(3) = TargetR(J, 3)
rs.Fields(4) = TargetR(J, 4)
rs.Fields(5) = TargetR(J, 5)
rs.Fields(6) = TargetR(J, 6)
rs.Fields(7) = TargetR(J, 7)
rs.Fields(8) = TargetR(J, 8)
rs.Update
Next

xlApp.Workbooks.Close
xlApp.Quit
Set xlApp = Nothing
MsgBox "成功導(dǎo)入庫存資料" & Round(Timer - stime, 0), vbInformation
Else
MsgBox "庫存文件不存在", vbCritical, "請檢查庫存文件路徑"
End If
Set rs = Nothing

Benjamin_luk

在查看過程中發(fā)現(xiàn), EXCEL運行時占20%~30%的CPU.
想了個方法, 就是將EXCEL數(shù)據(jù)轉(zhuǎn)給TARGETR后,關(guān)閉EXCEL, 這樣就可以加快速度.
藍色部分的代碼提了上來:
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim rs As Recordset
Dim I As Double, J As Integer, n As Integer
Dim TargetR, stime, DataK
If Dir(filstr) <> "" Then
stime = Timer
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(filstr)
Set xlSheet = xlBook.Worksheets(1)
CurrentDb.Execute "Delete * from [1 庫存（MB52）]"
Set rs = CurrentDb.OpenRecordset("1 庫存（MB52）")
'MsgBox rs.RecordCount
xlApp.ScreenUpdating = False
With xlSheet
I = .Range("A1").End(xlDown).Row
Set TargetR = .Range("A1:I" & I)
xlApp.ScreenUpdating = True
End With
xlApp.Workbooks.Close
xlApp.Quit
Set xlApp = Nothing
For J = 2 To I
rs.AddNew
rs.Fields(1) = TargetR(J, 1)
rs.Fields(2) = TargetR(J, 2)
rs.Fields(3) = TargetR(J, 3)
rs.Fields(4) = TargetR(J, 4)
rs.Fields(5) = TargetR(J, 5)
rs.Fields(6) = TargetR(J, 6)
rs.Fields(7) = TargetRJ, 7)
rs.Fields(8) = TargetR(J, 8)
rs.Update
Next
MsgBox "成功導(dǎo)入庫存資料" & Round(Timer - stime, 0), vbInformation
Else
MsgBox "庫存文件不存在", vbCritical, "請檢查庫存文件路徑"
End If
Set rs = Nothing

Benjamin_luk

但是出現(xiàn)問題了,
在用TARGETR進行賦值,提示錯誤"需要對象"
我想是因為EXCEL已關(guān)閉的原因, 那就將TARGETR轉(zhuǎn)到另一個變量,測試成功!
速度比TransferSpreadsheet要快得多了, 最后代碼如下:
紅色為新增加的變量
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim rs As Recordset
Dim I As Double, J As Integer, n As Integer
Dim TargetR, stime, DataK
If Dir(filstr) <> "" Then
stime = Timer
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(filstr)
Set xlSheet = xlBook.Worksheets(1)
CurrentDb.Execute "Delete * from [1 庫存（MB52）]"
Set rs = CurrentDb.OpenRecordset("1 庫存（MB52）")
'MsgBox rs.RecordCount
xlApp.ScreenUpdating = False
With xlSheet
I = .Range("A1").End(xlDown).Row
Set TargetR = .Range("A1:I" & I)
xlApp.ScreenUpdating = True
End With
DataK = TargetR
xlApp.Workbooks.Close
xlApp.Quit
Set xlApp = Nothing
For J = 2 To I
rs.AddNew
rs.Fields(1) = DataK(J, 1)
rs.Fields(2) = DataK(J, 2)
rs.Fields(3) = DataK(J, 3)
rs.Fields(4) = DataK(J, 4)
rs.Fields(5) = DataK(J, 5)
rs.Fields(6) = DataK(J, 6)
rs.Fields(7) = DataK(J, 7)
rs.Fields(8) = DataK(J, 8)
rs.Update
Next
MsgBox "成功導(dǎo)入庫存資料" & Round(Timer - stime, 0), vbInformation
Else
MsgBox "庫存文件不存在", vbCritical, "請檢查庫存文件路徑"
End If
Set rs = Nothing

todaynew

Benjamin_luk 發(fā)表于 2012-8-22 14:12
但是出現(xiàn)問題了,
在用TARGETR進行賦值,提示錯誤"需要對象"
我想是因為EXCEL已關(guān)閉的原因, 那就將TARGETR轉(zhuǎn) ...

方法是不錯。不過我怎么沒有看見1樓和2樓的代碼中給DataK對象賦值的語句？如果是這樣的話，三樓的代碼就多余了，應(yīng)該直接在給rs的字段賦值時用TargetR應(yīng)該就可以了。不知道是不是我老眼昏花了？

Benjamin_luk

todaynew 發(fā)表于 2012-8-22 15:17
方法是不錯。不過我怎么沒有看見1樓和2樓的代碼中給DataK對象賦值的語句？如果是這樣的話，三樓的代碼就多 ...

這是為了給大家有一個對比.
一樓是直接用TARGETR賦值, 再寫入RS, 然后關(guān)閉XLS, 速度太慢
二樓是XLS數(shù)據(jù)傳給TARGETR后關(guān)閉, 再寫入RS, 失敗(TARGETR數(shù)據(jù)沒有)
三樓是XLS數(shù)據(jù)轉(zhuǎn)給TARGETR, TARGETR轉(zhuǎn)給DATAK, 關(guān)閉XLS,寫入RS

只是作對比, 讓大家看得明白一些.

todaynew

Benjamin_luk 發(fā)表于 2012-8-22 16:13
這是為了給大家有一個對比.
一樓是直接用TARGETR賦值, 再寫入RS, 然后關(guān)閉XLS, 速度太慢
二樓是XLS數(shù) ...

我是問1樓和2樓的代碼中的
rs.Fields(1) = DataK(J, 1)是不是寫錯了，而是rs.Fields(1) = TargetR(J, 1)。

如果是這樣的話，三樓的代碼應(yīng)該不要，只需要將二樓的代碼修改一下就可以運行了。按說數(shù)據(jù)從Excel表讀到TargetR變量中后，關(guān)閉Excel對象不會釋放TargetR的數(shù)據(jù)。


我試了一下，不用另外一個變量過渡。你的問題是變量用錯了，呵呵。

Benjamin_luk

todaynew 發(fā)表于 2012-8-22 16:26
我是問1樓和2樓的代碼中的
rs.Fields(1) = DataK(J, 1)是不是寫錯了，而是rs.Fields(1) = TargetR(J,  ...

確定是寫錯, 是用最后的代碼COPY過來的,忘記修改了.
我這里測試2樓代碼時,確實是關(guān)閉EXCEL后, TARGETR的變量就沒數(shù)據(jù)了.{:soso_e101:}

運行環(huán)境:XP, OFFICE2007,ACCESS2003

roych

我一般喜歡鏈接表再進行處理。

todaynew

Benjamin_luk 發(fā)表于 2012-8-22 17:18
確定是寫錯, 是用最后的代碼COPY過來的,忘記修改了.
我這里測試2樓代碼時,確實是關(guān)閉EXCEL后, TARGETR ...

按你的思路，我試了一下讀取Word中的table數(shù)據(jù)，大體上也可以，不過讀出來的是一個有規(guī)律的字符串，需要用split分解為二維數(shù)組，總體上速度也是很快的。

Benjamin_luk

todaynew 發(fā)表于 2012-8-23 15:54
按你的思路，我試了一下讀取Word中的table數(shù)據(jù)，大體上也可以，不過讀出來的是一個有規(guī)律的字符串，需要用 ...

確實有點不明白, 將EXCEL數(shù)據(jù)轉(zhuǎn)給變量后,
不關(guān)閉EXCEL的速度為什么會慢,
數(shù)據(jù)傳遞后,EXCEL按理也不需要進行其他的任務(wù)了.