跪求excle统计宏，统计文件夹里多个excle指定工作表的指定内容，跪求各位大神啊~~

simon_k0219 · 发表于 2013-12-21 15:11

zhaogang1960 发表于 2013-12-17 23:55
SQL = "select * from [费用$a8:o] where 费用名称='苹果'"
中的费用就是工作表名，按照数据源真实工作 ...

赵老师，不好意思，又麻烦你，你写的那个宏十分方便，但我又有一个新的问题，我想在汇总表里再添加一个汇总项，如：在“A”文件里面有“苹果”的两行数据已经复制到新文件了，能不能在复制过去的两行数据前都加上“A”文件里“姓名”工作表里面“E7”单元格的内容呢？

样板.zip (28.35 KB, 下载次数: 3)

zhaogang1960 · 发表于 2013-12-21 15:38

simon_k0219 发表于 2013-12-21 15:11
赵老师，不好意思，又麻烦你，你写的那个宏十分方便，但我又有一个新的问题，我想在汇总表里再添加一个汇 ...

Sub Macro1()
Dim Fso As Object, File As Object, cnn As Object, SQL$
Dim objWMI As Object
Const HKEY_LOCAL_MACHINE = &H80000002
Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 60000
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
ActiveSheet.UsedRange.Offset(1).ClearContents
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
If File.Name Like "*.xls" And File.Name <> ThisWorkbook.Name Then
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1';Data Source=" & File
SQL = "select '" & cnn.Execute("[姓名$e7:e7]").Fields(0).Name & "',* from [费用$a8:o] where 费用名称='苹果'"
Range("h65536").End(xlUp).Offset(1, -7).CopyFromRecordset cnn.Execute(SQL)
End If
Next
Set Fso = Nothing
cnn.Close
Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2013-12-21 15:42

请测试附件

样板.rar (32.4 KB, 下载次数: 61)

simon_k0219 · 发表于 2013-12-28 23:22

经过一个星期的测试，赵老师的程序非常好，很方便，谢谢赵老师

simon_k0219 · 发表于 2014-4-11 09:47

zhaogang1960 发表于 2013-12-21 15:42
请测试附件

赵老师我在工作中又遇到一个新问题，就是我的excle文件是存放在多个文件夹里面，就是每天一个文件夹，如何在现在这个宏的基础上再作修改，能遍历总文件夹里面的子文件夹及其里面的excle呢？谢谢

zhaogang1960 · 发表于 2014-4-11 12:38

simon_k0219 发表于 2014-4-11 09:47
赵老师我在工作中又遇到一个新问题，就是我的excle文件是存放在多个文件夹里面，就是每天一个文件夹，如何 ...

只要这些子文件夹在同一个目录下，问题可以解决，请上传附件我看看

zhaogang1960 · 发表于 2014-4-12 22:37

simon_k0219 发表于 2014-4-12 22:11
附件如下：

Sub Macro1()
Dim Fso As Object, Folder As Object, arrf$(), mf&
Dim cnn As Object, SQL$
Dim objWMI As Object
Const HKEY_LOCAL_MACHINE = &H80000002
Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 60000
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Folder = Fso.GetFolder(ThisWorkbook.Path)
Call GetFiles(Folder, arrf, mf)
ActiveSheet.UsedRange.Offset(1).ClearContents
For i = 1 To mf
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1';Data Source=" & arrf(i)
SQL = "select '" & cnn.Execute("[姓名$e7:e7]").Fields(0).Name & "',* from [费用$a8:o] where 费用名称='苹果' or 费用名称 like '%西瓜%'"
Range("h65536").End(xlUp).Offset(1, -7).CopyFromRecordset cnn.Execute(SQL)
Next
End Sub
Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
Dim SubFolder As Object
Dim File As Object
For Each File In Folder.Files
If File.Name Like "*.xls" Then
If File.Name <> ThisWorkbook.Name Then
mf = mf + 1
ReDim Preserve arrf(1 To mf)
arrf(mf) = File
End If
End If
Next
For Each SubFolder In Folder.SubFolders
Call GetFiles(SubFolder, arrf, mf)
Next
End Sub

复制代码

simon_k0219 · 发表于 2014-4-12 22:11

附件如下：

simon_k0219 · 发表于 2014-4-12 22:13

zhaogang1960 发表于 2014-4-11 12:38
只要这些子文件夹在同一个目录下，问题可以解决，请上传附件我看看

样板.rar (51.28 KB, 下载次数: 1)

zhaogang1960 · 发表于 2014-4-12 22:39

请测试附件

样板.rar (53.34 KB, 下载次数: 45)

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

[求助] 跪求excle统计宏，统计文件夹里多个excle指定工作表的指定内容，跪求各位大神啊~~