Office中国论坛/Access中国论坛

标题: [分享]VBA加快Excel数据导入速度 [打印本页]
作者: Benjamin_luk    时间: 2012-8-22 14:04
标题: [分享]VBA加快Excel数据导入速度
本帖最后由 Benjamin_luk 于 2012-8-22 17:07 编辑

ACCESS本身是有TransferSpreadsheet的功能将EXCEL表格数据导入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 "成功导入库存资料" & Round(Timer - stime, 0), vbInformation
Else
MsgBox "库存文件不存在", vbCritical, "请检查库存文件路径"
End If
Set rs = Nothing
作者: Benjamin_luk    时间: 2012-8-22 14:07
本帖最后由 Benjamin_luk 于 2012-8-22 17:08 编辑

在查看过程中发现, EXCEL运行时占20%~30%的CPU.
想了个方法, 就是将EXCEL数据转给TARGETR后,关闭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 "成功导入库存资料" & Round(Timer - stime, 0), vbInformation
Else
MsgBox "库存文件不存在", vbCritical, "请检查库存文件路径"
End If
Set rs = Nothing
作者: Benjamin_luk    时间: 2012-8-22 14:12
本帖最后由 Benjamin_luk 于 2012-8-22 14:12 编辑

但是出现问题了,
在用TARGETR进行赋值,提示错误"需要对象"
我想是因为EXCEL已关闭的原因, 那就将TARGETR转到另一个变量,测试成功!
速度比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 "成功导入库存资料" & Round(Timer - stime, 0), vbInformation
Else
MsgBox "库存文件不存在", vbCritical, "请检查库存文件路径"
End If
Set rs = Nothing
作者: todaynew    时间: 2012-8-22 15:17
Benjamin_luk 发表于 2012-8-22 14:12
但是出现问题了,
在用TARGETR进行赋值,提示错误"需要对象"
我想是因为EXCEL已关闭的原因, 那就将TARGETR转 ...

方法是不错。不过我怎么没有看见1楼和2楼的代码中给DataK对象赋值的语句？如果是这样的话，三楼的代码就多余了，应该直接在给rs的字段赋值时用TargetR应该就可以了。不知道是不是我老眼昏花了？
作者: Benjamin_luk    时间: 2012-8-22 16:13
本帖最后由 Benjamin_luk 于 2012-8-22 16:14 编辑
todaynew 发表于 2012-8-22 15:17
方法是不错。不过我怎么没有看见1楼和2楼的代码中给DataK对象赋值的语句？如果是这样的话，三楼的代码就多 ...


这是为了给大家有一个对比.
一楼是直接用TARGETR赋值, 再写入RS, 然后关闭XLS, 速度太慢
二楼是XLS数据传给TARGETR后关闭, 再写入RS, 失败(TARGETR数据没有)
三楼是XLS数据转给TARGETR, TARGETR转给DATAK, 关闭XLS,写入RS

只是作对比, 让大家看得明白一些.
作者: todaynew    时间: 2012-8-22 16:26
本帖最后由 todaynew 于 2012-8-22 16:50 编辑
Benjamin_luk 发表于 2012-8-22 16:13
这是为了给大家有一个对比.
一楼是直接用TARGETR赋值, 再写入RS, 然后关闭XLS, 速度太慢
二楼是XLS数 ...


我是问1楼和2楼的代码中的
rs.Fields(1) = DataK(J, 1)是不是写错了，而是rs.Fields(1) = TargetR(J, 1)。

如果是这样的话，三楼的代码应该不要，只需要将二楼的代码修改一下就可以运行了。按说数据从Excel表读到TargetR变量中后，关闭Excel对象不会释放TargetR的数据。


我试了一下，不用另外一个变量过渡。你的问题是变量用错了，呵呵。
作者: Benjamin_luk    时间: 2012-8-22 17:18
本帖最后由 Benjamin_luk 于 2012-8-22 17:18 编辑
todaynew 发表于 2012-8-22 16:26
我是问1楼和2楼的代码中的
rs.Fields(1) = DataK(J, 1)是不是写错了，而是rs.Fields(1) = TargetR(J,  ...


确定是写错, 是用最后的代码COPY过来的,忘记修改了.
我这里测试2楼代码时,确实是关闭EXCEL后, TARGETR的变量就没数据了.{:soso_e101:}

运行环境:XP, OFFICE2007,ACCESS2003
作者: roych    时间: 2012-8-22 18:57
我一般喜欢链接表再进行处理。
作者: todaynew    时间: 2012-8-23 15:54
Benjamin_luk 发表于 2012-8-22 17:18
确定是写错, 是用最后的代码COPY过来的,忘记修改了.
我这里测试2楼代码时,确实是关闭EXCEL后, TARGETR ...

按你的思路，我试了一下读取Word中的table数据，大体上也可以，不过读出来的是一个有规律的字符串，需要用split分解为二维数组，总体上速度也是很快的。
作者: Benjamin_luk    时间: 2012-8-23 17:38
todaynew 发表于 2012-8-23 15:54
按你的思路，我试了一下读取Word中的table数据，大体上也可以，不过读出来的是一个有规律的字符串，需要用 ...

确实有点不明白, 将EXCEL数据转给变量后,
不关闭EXCEL的速度为什么会慢,
数据传递后,EXCEL按理也不需要进行其他的任务了.

作者: todaynew    时间: 2012-8-24 11:58
Benjamin_luk 发表于 2012-8-23 17:38
确实有点不明白, 将EXCEL数据转给变量后,
不关闭EXCEL的速度为什么会慢,
数据传递后,EXCEL按理也不需要 ...

可能是在对象中搜索元素比在数组中搜索元素计算要复杂吧？

此外，Set TargetR = .Range("A1:I" & I) 语句应该是设置一个对象，而DataK = TargetR似乎是将对象元素的值转换为数组赋值给了DataK。由此可不必设置TargetR对象，而直接写为DataK=.Range("A1:I" & I)，这样关闭Excel表对象，DataK数组并不受影响。



欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3