汇总多个工作薄包含特定内容的工作表信息

无助的人0408

各位大虾，现有多个工作薄汇总问题需要请教。
有三个工作薄要汇总包含北京的工作表信息。
一个工作薄中包含有北京地区、石家庄
另一个工作薄包含北京分区、石家庄
第三个工作薄包含天津
最好是在不打开工作薄的情况下，判断是否包含有北京的工作表，如有汇总，如无退出，再找下一个工作薄。
新建文件夹.rar (25.39 KB, 下载次数: 11)

2013-5-3 17:21 上传

点击文件名下载附件

谢谢各位了

zhaogang1960

ADO法不用"打开"，请测试：

1. Sub 宏1()
   
2.     Dim cnn As Object, cat As Object, tb1 As Object
   
3.     Dim SQL$, MyFile$, s$, m&, n&, t$
   
4.     Application.ScreenUpdating = False
   
5.     Set cnn = CreateObject("ADODB.Connection")
   
6.     Set cat = CreateObject("ADOX.Catalog")
   
7.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
8.     MyPath = ThisWorkbook.Path & ""
   
9.     MyFile = Dir(MyPath & "*.xlsx")
   
10.     Do While MyFile <> ""
    
11.         If MyFile <> ThisWorkbook.Name Then
    
12.             n = n + 1
    
13.             If n = 1 Then
    
14.                 cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath & MyFile
    
15.             Else
    
16.                 t = "[Excel 8.0;Database=" & MyPath & MyFile & "]."
    
17.             End If
    
18.             cat.ActiveConnection = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath & MyFile
    
19.             For Each tb1 In cat.Tables
    
20.                 If tb1.Type = "TABLE" Then
    
21.                     s = Replace(tb1.Name, "'", "")
    
22.                     If Right(s, 1) = "$" And InStr(s, "北京") > 0 Then
    
23.                         m = m + 1
    
24.                         If m > 49 Then
    
25.                             Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
26.                             m = 1
    
27.                             SQL = ""
    
28.                         End If
    
29.                         If Len(SQL) Then SQL = SQL & " union all "
    
30.                         SQL = SQL & "select * from " & t & "[" & s & "]"
    
31.                     End If
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.         MyFile = Dir()
    
36.     Loop
    
37.     If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
38.     cnn.Close
    
39.     Set cnn = Nothing
    
40.     Set cat = Nothing
    
41.     Set tb1 = Nothing
    
42.     Application.ScreenUpdating = True
    
43. End Sub
    
44. 
    

复制代码

zhaogang1960

请看附件
新建文件夹.rar (35.39 KB, 下载次数: 29)

2013-5-3 17:40 上传

点击文件名下载附件

无助的人0408

现在我将固定位置改为选择文件夹位置，提示出错。

然后在此处中断

指明原因。
汇总表.rar (21.19 KB, 下载次数: 2)

2013-5-4 20:34 上传

点击文件名下载附件

另如果想在汇总结果前加上工作薄名如何做。

LMY123

For Each tb1 In cat.Tables