不同工作薄的指定名称工作表自动汇总

wujin219

求大家帮忙！对宏一知半解，查了半天无法举一反三，只能求高手帮忙直接解决一下！不胜感激！

wujin219

把附件中两个文件夹中所有工作薄的第二个工作表“汇总”汇总到新的同一个工作表中

feiren228

wujin219 发表于 2015-9-23 15:17
把附件中两个文件夹中所有工作薄的第二个工作表“汇总”汇总到新的同一个工作表中

请测试》》

1. Sub ado()  'by feiren228
   
2.     Application.ScreenUpdating = False
   
3.     Dim fr$(), m%, p$, i&, j%, r&
   
4.     Dim cnn As Object, rs As Object, sql$
   
5.     p = ThisWorkbook.Path: m = 0
   
6.     Call GetFiles(fr, m, p)
   
7.     Set cnn = CreateObject("Adodb.Connection")
   
8.     Set rs = CreateObject("adodb.recordset")
   
9.     If Application.Version * 1 <= 11 Then
   
10.         cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
    
11.     Else
    
12.         cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;imex=1;hdr=yes';Data Source=" & ThisWorkbook.FullName
    
13.     End If
    
14.     If m = 0 Then MsgBox "当前文件夹下没有需要汇总的文件！": Exit Sub
    
15.     With Sheets("汇总")
    
16.         .UsedRange.Clear
    
17.         .Range("A:A").NumberFormatLocal = "@"
    
18.         For i = 1 To UBound(fr)
    
19.             sql = "select * from [Excel 8.0;imex=1;hdr=yes;Database=" & fr(i) & "].[汇总$A2:BC] "
    
20.             Set rs = cnn.Execute(sql)
    
21.             If i = 1 Then
    
22.                 For j = 0 To rs.Fields.Count - 1
    
23.                     .Cells(1, j + 1) = rs.Fields(j).Name
    
24.                 Next j
    
25.             End If
    
26.             r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
    
27.             .Cells(r, 1).CopyFromRecordset rs
    
28.         Next
    
29.         .UsedRange.Columns.AutoFit
    
30.     End With
    
31.     rs.Close
    
32.     Set rs = Nothing
    
33.     Set cnn = Nothing
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    
36. 
    
37. Sub GetFiles(fr$(), m%, ByVal p$)
    
38.     'p为遍历的路径，fr为存储文件路径数组
    
39.     Dim SubFolder As Object
    
40.     Dim File As Object
    
41.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
42.     Set Folder = FSO.GetFolder(p)
    
43.     For Each File In Folder.Files
    
44.         If File.Name <> ThisWorkbook.Name Then
    
45.             If File.Name Like "*.xls" Or File.Name Like "*.xlsx" Then
    
46.                 m = m + 1
    
47.                 ReDim Preserve fr(1 To m)
    
48.                 fr(m) = File
    
49.             End If
    
50.         End If
    
51.     Next
    
52.     For Each SubFolder In Folder.SubFolders
    
53.         Call GetFiles(fr, m, SubFolder.Path)
    
54.     Next
    
55. End Sub
    

复制代码

feiren228

。。。。
不同工作薄的指定名称工作表汇总_test.zip (285.45 KB, 下载次数: 49)

2015-9-23 17:22 上传

点击文件名下载附件

LMY123

sql = "select * from [Excel 8.0;imex=1;hdr=yes;Database=" & fr(i) & "].[汇总$A2:BC] "