多表汇总求提速

朝旭暮阳 · 发表于 2016-1-31 00:11

多张工作表，格式为.xlsm，带宏的，每张表中有个名为数据库的工作表，位置为当前文件夹以及子文件夹，现用代码为SQL语句

Function fld(Path As String)
Dim Fso As Object
Dim f As Object
Dim fd As Object
Dim subf As Object
Set Fso = CreateObject("scripting.FileSystemObject")
Set fd = Fso.GetFolder(Path)
      For Each f In fd.Files
      l = l + 1
      ReDim Preserve arr(1 To l)
      arr(l) = f.Path
Next
      For Each subf In fd.SubFolders
      fld (subf.Path)
Next
End Function
Sub 汇总文件夹以及子文件夹()
t = Timer - t
Application.ScreenUpdating = False
On Error Resume Next
Dim mySQL As String
Dim mycnn
Dim f As String
Dim File() As String
Dim i, k, x
x = 1
i = 1: k = 1
ReDim File(1 To i)
File(1) = ActiveWorkbook.Path & "\"
Do Until i > k
f = Dir(File(i), vbDirectory)
      Do Until f = ""
         If InStr(f, ".") = 0 Then
            k = k + 1
            ReDim Preserve File(1 To k)
            File(k) = File(i) & f & "\"
         End If
         f = Dir
      Loop
i = i + 1
Loop
For i = 1 To k
f = Dir(File(i) & "*.xlsm")
Do
      Set mycnn = CreateObject("adodb.connection")
      If f <> ThisWorkbook.Name Then
         mycnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & File(i) & f & ""
         mySQL = "select * from [数据库$]"
         Range("A65536").End(xlUp).Offset(1, 0).CopyFromRecordset mycnn.Execute(mySQL)
      End If
   Set mycnn = Nothing
   f = Dir
Loop While Len(f) And f <> ThisWorkbook.Name
Next
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

速度还是不尽人意，在此请求老师支招感激不尽

朝旭暮阳 · 发表于 2016-1-31 00:14

不知道有没有更快的汇总办法

zhaogang1960 · 发表于 2016-1-31 00:36

提速一倍多一点，不是很理想：

Sub Macro1()
t = Timer
Dim Fso As Object, Folder As Object, arr$(), m&, i&, p$
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Folder = Fso.GetFolder(ThisWorkbook.Path)
Call GetFiles(Folder, arr, m)
Set mycnn = CreateObject("adodb.connection")
mycnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & arr(1)
ActiveSheet.UsedRange.Offset(1).ClearContents
For i = 1 To m
mySQL = "select * from [Excel 12.0;Database=" & arr(i) & "].[数据库$]"
Range("A65536").End(xlUp).Offset(1, 0).CopyFromRecordset mycnn.Execute(mySQL)
Next
Application.ScreenUpdating = True
Set Folder = Nothing
Set Fso = Nothing
MsgBox Timer - t
End Sub
Sub GetFiles(ByVal Folder As Object, arr$(), m&)
Dim SubFolder As Object
Dim File As Object
If Folder.Path <> ThisWorkbook.Path Then
For Each File In Folder.Files
If File.Name Like "*.xls*" Then
m = m + 1
ReDim Preserve arr(1 To m)
arr(m) = File
End If
Next
End If
For Each SubFolder In Folder.SubFolders
Call GetFiles(SubFolder, arr, m)
Next
End Sub

复制代码

朝旭暮阳 · 发表于 2016-1-31 07:25

谢谢赵老师，不知道用字典会不会更快

朝旭暮阳 · 发表于 2016-1-31 07:27

zhaogang1960 发表于 2016-1-31 00:36
提速一倍多一点，不是很理想：

字典是不是更快，求告知，或者有别的办法呢

zhaogang1960 · 发表于 2016-1-31 10:31

朝旭暮阳发表于 2016-1-31 07:27
字典是不是更快，求告知，或者有别的办法呢

本题目仅合并数据，与字典无关，速度慢主要原因是待合并文件太多（492个），我认为没有比SQL法速度快的其他方法了，如果采用逐个打开复制数据，或写入数组，用时应该超过10分钟

crazy0qwer · 发表于 2016-1-31 12:06

zhaogang1960 发表于 2016-1-31 10:31
本题目仅合并数据，与字典无关，速度慢主要原因是待合并文件太多（492个），我认为没有比SQL法速度快的其 ...

虽然比不上SQL，但是也不至于需要十分钟如此不堪吧。简单测试了下不到一分钟。
普通方法耗时主要是打开和关闭文件。

zhaogang1960 · 发表于 2016-1-31 12:25

crazy0qwer 发表于 2016-1-31 12:06
虽然比不上SQL，但是也不至于需要十分钟如此不堪吧。简单测试了下不到一分钟。
普通方法耗时主要是打开 ...

我估计的有点过，经测试下面程序运行259秒，我改写的SQL法为18秒：

Sub Macro1()
t = Timer
Dim Fso As Object, Folder As Object, arr$(), m&, i&, sh As Worksheet
Application.ScreenUpdating = False
Set sh = ActiveSheet
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Folder = Fso.GetFolder(ThisWorkbook.Path)
Call GetFiles(Folder, arr, m)
ActiveSheet.UsedRange.Offset(1).ClearContents
For i = 1 To m
      With GetObject(arr(i))
         .Sheets("数据库").UsedRange.Offset(1).Copy sh.Range("A65536").End(xlUp).Offset(1)
         .Close 0
      End With
Next
Application.ScreenUpdating = True
Set Folder = Nothing
Set Fso = Nothing
MsgBox Timer - t
End Sub

Sub GetFiles(ByVal Folder As Object, arr$(), m&)
Dim SubFolder As Object
Dim File As Object
If Folder.Path <> ThisWorkbook.Path Then
      For Each File In Folder.Files
         If File.Name Like "*.xls*" Then
            m = m + 1
            ReDim Preserve arr(1 To m)
            arr(m) = File
         End If
      Next
End If
For Each SubFolder In Folder.SubFolders
      Call GetFiles(SubFolder, arr, m)
Next
End Sub

你的打开、关闭算法速度快，请传上来分享一下

crazy0qwer · 发表于 2016-1-31 12:48

zhaogang1960 发表于 2016-1-31 12:25
我估计的有点过，经测试下面程序运行259秒，我改写的SQL法为18秒：

Sub Macro1()

如果楼主的数据是CSV文件的话还有办法，XLSM 就没办法了，普通方法只能在excel打开。

我用您SQL方法时间是 6.8 S ，而我的代码时间是 56.9 将近十倍。
而用您8楼getobject 方法时间为 109.2 。

之前我也有测试过 getobject ，不过这样打开反而比关闭屏幕更新后的workbooks.open要慢得多，我想也许是这个方法需要匹配文件的类型，才能选择对应的程序来打开，最终也还是需要用excel来打开，所以速度慢很多。

附我的代码，比一般多做了一步：禁用宏的方式打开工作簿，避免因为工作簿中open过程的宏影响。

Sub Macro1()
t = Timer
Dim Fso As Object, Folder As Object, arr$(), m&, i&, p$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
x = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Folder = Fso.GetFolder(ThisWorkbook.Path)
Call GetFiles(Folder, arr, m)
Sheet2.UsedRange.Offset(1).ClearContents
n = 2
For i = 2 To m
With Workbooks.Open(arr(i), False)
.Sheets("数据库").Range("a1").CurrentRegion.Offset(1).Copy Sheet2.Range("A1048576").End(xlUp).Offset(1)
n = n + UBound(arr) - 1
.Close False
End With
Next
Application.ScreenUpdating = True
Application.AutomationSecurity = x
Set Folder = Nothing
Set Fso = Nothing
Debug.Print Timer - t
End Sub

复制代码

zhaogang1960 · 发表于 2016-1-31 13:04

crazy0qwer 发表于 2016-1-31 12:48
如果楼主的数据是CSV文件的话还有办法，XLSM 就没办法了，普通方法只能在excel打开。

我用您SQL方法时 ...

谢谢。
看来我和楼主一样，电脑配置太差了，如果楼主的电脑中SQL方法也是6.8 S，应该很满意了，复制492个工作簿的数据工作量不小

		自动登录	找回密码
密码			免费注册

[求助] 多表汇总求提速

评分

评分