遍历文件夹下的工作簿、工作表进行取数，无需打开文件，求助。

zhaogang1960

下面附件中有24个文件，工作表数超过49个：
HelpSample.rar (210.18 KB, 下载次数: 348)

2012-4-16 19:25 上传

点击文件名下载附件

whggwu

zhaogang1960 发表于 2012-4-16 19:25
下面附件中有24个文件，工作表数超过49个：

我就简单复制了文件进行测试，是否实质为工作表数量问题还不知道
这个文件，我执行宏怎么文件就关了？反复多次还是这样。
有时候是不是EXCEL、电脑问题呢？因为曾经有一个文件，我在办公室的电脑EXCEL2010有些宏就运行没问题，但是家里的电脑也是EXCEL2010就出现问题，提示错误。

zhaogang1960

whggwu 发表于 2012-4-16 21:41
我就简单复制了文件进行测试，是否实质为工作表数量问题还不知道
这个文件，我执行宏怎么文件就关了？反 ...

应该是电脑的问题，我这里运行正常

whggwu

zhaogang1960 发表于 2012-4-16 22:00
应该是电脑的问题，我这里运行正常

嗯，是电脑问题，在办公室就可以，没问题

谢谢！

XUYUJING2007

zhaogang1960 发表于 2012-4-16 19:25
下面附件中有24个文件，工作表数超过49个：

赵老师，如果要对数据分类求和，用SQL代码要怎么写

zhaogang1960

XUYUJING2007 发表于 2012-6-25 10:16
赵老师，如果要对数据分类求和，用SQL代码要怎么写

这个题目不好修改，请上传附件

XUYUJING2007

zhaogang1960 发表于 2012-6-25 11:06
这个题目不好修改，请上传附件

HelpSample.rar (210.19 KB, 下载次数: 41)

2012-6-25 11:14 上传

点击文件名下载附件

就是对文件夹里的表格中的数据按日期进行分类汇总

zhaogang1960

XUYUJING2007 发表于 2012-6-25 11:14
就是对文件夹里的表格中的数据按日期进行分类汇总

1. Sub Macro1()
   
2. '引用Microsoft AD0 Ext 2.8 for DDL and Security
   
3. '引用Microsoft ActiveX Data Objects 2.x Library
   
4.     Dim cnn As New ADODB.Connection
   
5.     Dim rs As ADODB.Recordset
   
6.     Dim cat  As New ADOX.Catalog, tb1 As Table
   
7.     Dim d As Object
   
8.     Dim SQL$, MyFile$, m%, i%, temp$, strField$, s$, t$, t2$, n%
   
9.     Application.ScreenUpdating = False
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Sheets("项目取数").[a1].CurrentRegion.Offset(3).ClearContents
    
12.     Sheets("基础信息").[a1].CurrentRegion.Offset(3).ClearContents
    
13.     Mypath = ThisWorkbook.Path & ""
    
14.     MyFile = Dir(Mypath & "*.xlsx")
    
15.     Do While MyFile <> ""
    
16.         If MyFile <> ThisWorkbook.Name Then
    
17.             n = n + 1
    
18.             If n > 1 Then
    
19.                 t = "[Excel 12.0;Database=" & Mypath & MyFile & "]."
    
20.             Else
    
21.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath & MyFile
    
22.             End If
    
23.             t2 = "[Excel 12.0;HDR=No;Database=" & Mypath & MyFile & "]."
    
24.             cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & Mypath & MyFile
    
25.             For Each tb1 In cat.Tables
    
26.                 If tb1.Type = "TABLE" Then
    
27.                     s = Replace(tb1.Name, "'", "")
    
28.                     If Right(s, 1) = "$" Then
    
29.                         m = m + 1
    
30.                         If m = 1 Then
    
31.                             Set rs = cnn.Execute("[" & s & "a5:d]")
    
32.                             For i = 0 To rs.Fields.Count - 1
    
33.                                 temp = temp & rs.Fields(i).Name & ","
    
34.                             Next
    
35.                         End If
    
36.                         SQL = "select * from " & t & "[" & s & "a5:d]"
    
37.                         d(SQL) = ""
    
38.                         If m Mod 49 = 0 Then
    
39.                             SQL = Join(d.Keys, " UNION ALL ")
    
40.                             Sheets("项目取数").[a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
41.                             d.RemoveAll
    
42.                         End If
    
43.                     End If
    
44.                 End If
    
45.             Next
    
46.         End If
    
47.         MyFile = Dir()
    
48.     Loop
    
49.     If d.Count > 0 Then
    
50.         SQL = Join(d.Keys, " UNION ALL ")
    
51.         Sheets("项目取数").[a65536].End(3).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
52.     End If
    
53.     With Sheets("项目取数")
    
54.         SQL = "select 日期,sum(项目1),sum(项目2),sum(项目3) from [Excel 12.0;Database=" & ThisWorkbook.FullName & "].[项目取数$a3:d] group by 日期"
    
55.         Set rs = New ADODB.Recordset
    
56.         rs.Open SQL, cnn, 1, 3
    
57.         .Range("a4").CopyFromRecordset rs
    
58.         .Range("a1").CurrentRegion.Offset(rs.RecordCount + 3).ClearContents
    
59.     End With
    
60.     rs.Close
    
61.     cnn.Close
    
62.     Set rs = Nothing
    
63.     Set cnn = Nothing
    
64.     Set cat = Nothing
    
65.     Set tb1 = Nothing
    
66.     Application.ScreenUpdating = True
    
67. End Sub

复制代码

zhaogang1960

请看附件
HelpSample.rar (210.72 KB, 下载次数: 270)

2012-6-25 12:53 上传

点击文件名下载附件

XUYUJING2007

zhaogang1960 发表于 2012-6-25 12:53
请看附件

谢谢赵老师的解答