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

simon_k0219

样板.rar (13.61 KB, 下载次数: 18)

2013-12-16 23:56 上传

点击文件名下载附件
样板

有一个文件夹里面有几百个excle文件，excle文件格式一样。现在要求不打开excle文件，直接查找每个excle“费用”工作表里面是否含有“苹果”，有的话将含有苹果的该行数据复制到新的excle文件里。如附件：样板

zhaogang1960

欢迎新会员，请测试：

1. Sub Macro1()
   
2.     Dim Fso As Object, File As Object, cnn As Object, SQL$
   
3.     Dim objWMI As Object
   
4.     Const HKEY_LOCAL_MACHINE = &H80000002
   
5.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
6.     objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 60000
   
7.     Application.ScreenUpdating = False
   
8.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
9.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
10.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
    
11.         If File.Name Like "*.xls" And File.Name <> ThisWorkbook.Name Then
    
12.             Set cnn = CreateObject("adodb.connection")
    
13.             cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1';Data Source=" & File
    
14.             SQL = "select * from [费用$a8:o] where 费用名称='苹果'"
    
15.             Range("g65536").End(xlUp).Offset(1, -6).CopyFromRecordset cnn.Execute(SQL)
    
16.         End If
    
17.     Next
    
18.     Set Fso = Nothing
    
19.     cnn.Close
    
20.     Set cnn = Nothing
    
21.     Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

zhaogang1960

请看附件
样板.rar (21.68 KB, 下载次数: 65)

2013-12-17 01:54 上传

点击文件名下载附件

nhygm

赵老师：
请帮忙解释一下好吗？
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")
这几行我没看懂{:soso_e127:}

zhaogang1960

nhygm 发表于 2013-12-17 11:03
赵老师：
请帮忙解释一下好吗？
Const HKEY_LOCAL_MACHINE = &H80000002

这几句用来修改注册表
1楼附件中数据是数字文本混排的，但SQL通常自动测试前8条记录的数据类型，如果数字占50%，则按照数字对待，否则按照文本对待，所以加了imex=1参数，强制所有类型都按照文本，并通过修改注册表让SQL自动测试的记录数加大

nhygm

赵老师：
如果导出的 各个文件的工作表的名字不一样（工作表不是SHEET1）怎么办啊？？
像楼上的例子中 所有的表名都是 【费用$】如果不一样怎么在SQL中定义啊？？？

zhaogang1960

nhygm 发表于 2013-12-17 14:59
赵老师：
如果导出的 各个文件的工作表的名字不一样（工作表不是SHEET1）怎么办啊？？

可以用adSchemaTables方法取得工作表名，请参考：

1. Sub Macro2() 'adSchemaTables法
   
2.     Dim cnn As Object
   
3.     Dim rs As Object
   
4.     Dim n&, s$, arr()
   
5.     Set cnn = CreateObject("adodb.connection")
   
6.     Set rs = CreateObject("adodb.Recordset")
   
7.     cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.Path & "\book1.xls"
   
8.     Set rs = cnn.OpenSchema(20) 'adSchemaTables
   
9.     Do Until rs.EOF
   
10.         If rs.Fields("TABLE_TYPE") = "TABLE" Then
    
11.             s = rs("TABLE_NAME").Value
    
12.             If Right(s, 1) = "$" Then
    
13.                 n = n + 1
    
14.                 ReDim Preserve arr(1 To n)
    
15.                 arr(n) = s
    
16.             End If
    
17.         End If
    
18.         rs.MoveNext
    
19.     Loop
    
20.     rs.Close
    
21.     Set rs = Nothing
    
22.     cnn.Close
    
23.     Set cnn = Nothing
    
24.     MsgBox Join(arr, ",")
    
25. End Sub
    

复制代码

simon_k0219

十分感谢赵老师，我还有一个问题，  SQL = "select * from [费用$a8:o] where 费用名称='苹果'"这行代码，里面，如果我的工作表有变动，但工作表里面的格式不变，需要怎么修改呢？我试过将“[费用$a8:o]”修改成“[应交费用$a8:o]”，但结果不能运行，求解，本人比较笨，希望不吝赐教，谢谢。

zhaogang1960

simon_k0219 发表于 2013-12-17 23:51
十分感谢赵老师，我还有一个问题，  SQL = "select * from [费用$a8:o] where 费用名称='苹果'"这行代码，里 ...

SQL = "select * from [费用$a8:o] where 费用名称='苹果'"
中的费用就是工作表名，按照数据源真实工作表名修改即可

如果不能正确运行，请上传出错工作簿分析一下

simon_k0219

已经解决了，谢谢赵老师。{:soso_e163:}