同一文件夹下多个工作薄中相同格式工作表数据据汇总

tianyunjie

在一个文件夹下，有许多个工作薄，每个工作薄格式内容都一样，不一样的只是内容对应的数据，在这个文件夹下同时存在一个汇总表，汇总表格式跟其他工作表格式也一样，现在要求打只开汇总表可以直接汇总各个其他工作薄中的数据。

谢谢~

tianyunjie

我还在等……大家帮帮忙吧！

天籁之音符

如何汇总 你的3个工作薄都是3列
汇总表也是3列。。。

天籁之音符

汇总表的B2 = 每个表 B2 的和？
汇总表的B3 = 每个表 B3 的和？

tianyunjie

天籁之音符 发表于 2012-11-29 16:04
汇总表的B2 = 每个表 B2 的和？
汇总表的B3 = 每个表 B3 的和？

是的，每个工作薄格式都一样的，包括汇总表，所以只是简单的对应单元格求和。

zhaogang1960

ADO法请参考:

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, SQL$, p$, f$, m&, n&, t$, s$, i&, Field1$
   
3.     Application.ScreenUpdating = False
   
4.     Cells.ClearContents
   
5.     Set cnn = CreateObject("ADODB.Connection")
   
6.     p = ThisWorkbook.Path & ""
   
7.     f = Dir(p & "*.xls")
   
8.     Do While f <> ""
   
9.         If f <> ThisWorkbook.Name Then
   
10.             n = n + 1
    
11.             If n = 1 Then
    
12.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & p & f
    
13.                 Set rs = cnn.Execute("[Sheet1$]")
    
14.                 s = rs.Fields(0).Name
    
15.                 [a1] = s
    
16.                 Field1 = s
    
17.                 For i = 1 To rs.Fields.Count - 1
    
18.                     Cells(1, i + 1) = rs.Fields(i).Name
    
19.                     s = s & ",sum(" & rs.Fields(i).Name & ")"
    
20.                 Next
    
21.                 rs.Close
    
22.                 Set rs = Nothing
    
23.             Else
    
24.                 t = "[Excel 8.0;Database=" & p & f & "]."
    
25.             End If
    
26.             m = m + 1
    
27.             If m > 49 Then
    
28.                 SQL = "select " & s & " from (" & SQL & ") group by " & Field1
    
29.                 Range("a65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
30.                 m = 1
    
31.                 SQL = ""
    
32.             End If
    
33.             If Len(SQL) Then SQL = SQL & " union all "
    
34.             SQL = SQL & "select * from " & t & "[Sheet1$]"
    
35.         End If
    
36.         f = Dir()
    
37.     Loop
    
38.     If Len(SQL) Then
    
39.         SQL = "select " & s & " from (" & SQL & ") group by " & Field1
    
40.         Range("a65536").End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
    
41.     End If
    
42.     cnn.Close
    
43.     Set cnn = Nothing
    
44.     Application.ScreenUpdating = True
    
45. End Sub

复制代码

zhaogang1960

请看附件
同一文件夹下多个工作薄中相同格式工作表数据据汇总.rar (23.23 KB, 下载次数: 1431)

2012-11-29 16:40 上传

点击文件名下载附件

tianyunjie

zhaogang1960 发表于 2012-11-29 16:40
请看附件

谢谢哈，这个问题终于可以解决了，有其他问题再问你哈~

tianyunjie

zhaogang1960 发表于 2012-11-29 16:40
请看附件

有个小问题，汇总表汇总完数据后，汇总表中的内容排序发生了变化，能不能不做改变呢？

zhaogang1960

tianyunjie 发表于 2012-11-29 17:22
有个小问题，汇总表汇总完数据后，汇总表中的内容排序发生了变化，能不能不做改变呢？

ADO联合查询做不到，ADO数组+字典请测试：

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, SQL$, p$, f$, r&, n&
   
3.     Dim arr, brr(), i&, j&, d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Set cnn = CreateObject("ADODB.Connection")
   
7.     p = ThisWorkbook.Path & ""
   
8.     f = Dir(p & "*.xls")
   
9.     Do While f <> ""
   
10.         If f <> ThisWorkbook.Name Then
    
11.             n = n + 1
    
12.             If n = 1 Then
    
13.                 cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & p & f
    
14.                 Set rs = cnn.Execute("[Sheet1$]")
    
15.                 ReDim brr(60000, rs.Fields.Count - 1)
    
16.                 For i = 0 To rs.Fields.Count - 1
    
17.                     brr(0, i) = rs.Fields(i).Name
    
18.                 Next
    
19.                 arr = rs.GetRows
    
20.                 rs.Close
    
21.                 Set rs = Nothing
    
22.             Else
    
23.                 SQL = "select * from [Excel 8.0;Database=" & p & f & "].[Sheet1$]"
    
24.                 arr = cnn.Execute(SQL).GetRows
    
25.             End If
    
26.             For j = 0 To UBound(arr, 2)
    
27.                 If Not d.Exists(arr(0, j)) Then
    
28.                     r = r + 1
    
29.                     d(arr(0, j)) = r
    
30.                     For i = 0 To UBound(arr)
    
31.                         brr(r, i) = arr(i, j)
    
32.                     Next
    
33.                 Else
    
34.                     For i = 1 To UBound(arr)
    
35.                         brr(d(arr(0, j)), i) = brr(d(arr(0, j)), i) + arr(i, j)
    
36.                     Next
    
37.                 End If
    
38.             Next
    
39.         End If
    
40.         f = Dir()
    
41.     Loop
    
42.     cnn.Close
    
43.     Set cnn = Nothing
    
44.     Cells.ClearContents
    
45.     [a1].Resize(r + 1, i) = brr
    
46.     Application.ScreenUpdating = True
    
47. End Sub
    

复制代码