不同格式的多工作簿多工作表汇总（导入）

学不完用不尽

请写个程序
要求：
按照“汇总表”工作簿的“合并工作簿”工作表中的第一行字段，将除“汇总表”工作簿外的所有工作簿里的工作表，导入到此表中的对应字段里，其中：“单位”字段为各工作簿里的各工作表里的“单位”字段；“年”字段为各工作簿名称的前4个字符，例如，工作簿名称为“2010年门店收支.xls”，“年”字段就为“2010”，其他以此类推。
注：如果被导入的工作簿里的工作表为空表（无数据），则不导入该工作表。

不同格式的多工作薄多工作表的汇总.rar (58.7 KB, 下载次数: 148)

2013-6-29 21:20 上传

点击文件名下载附件

提示：由于工作簿多，示例中的数据不准确（只是示范一下）。

补充内容 (2013-8-19 21:05):
已解决！

lzqmsy

留个记号,等待答案

zhaogang1960

请测试:

1. Sub Macro1()
   
2.     Dim p$, f$, arr, brr(1 To 60000, 1 To 256), d As Object, ds As Object, i&, j, m&, n&, r, y$
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set ds = CreateObject("scripting.dictionary")
   
5.     ds("单位") = 1
   
6.     ds("年") = 2
   
7.     n = 2
   
8.     p = ThisWorkbook.Path & ""
   
9.     f = Dir(p & "*.xls")
   
10.     Application.ScreenUpdating = False
    
11.     Do While f <> ""
    
12.         If f <> ThisWorkbook.Name Then
    
13.             With GetObject(p & f)
    
14.                 arr = .Sheets(1).[a1].CurrentRegion
    
15.                 .Close False
    
16.             End With
    
17.             If IsArray(arr) Then
    
18.                 y = Left$(f, 4)
    
19.                 For j = 2 To UBound(arr, 2)
    
20.                     If Not ds.Exists(arr(1, j)) Then
    
21.                         n = n + 1
    
22.                         ds(arr(1, j)) = n
    
23.                     End If
    
24.                 Next
    
25.                 For i = 2 To UBound(arr)
    
26.                     s = arr(i, 1) & Chr(9) & y & Chr(9) & arr(i, 2) & Chr(9) & arr(i, 3)
    
27.                     r = d(s)
    
28.                     If r = "" Then
    
29.                         m = m + 1
    
30.                         d(s) = m
    
31.                         brr(m, 1) = arr(i, 1)
    
32.                         brr(m, 2) = y
    
33.                         For j = 2 To UBound(arr, 2)
    
34.                             brr(m, ds(arr(1, j))) = arr(i, j)
    
35.                         Next
    
36.                     Else
    
37.                         For j = 4 To UBound(arr, 2)
    
38.                             brr(r, ds(arr(1, j))) = brr(r, ds(arr(1, j))) + arr(i, j)
    
39.                         Next
    
40.                     End If
    
41.                 Next
    
42.             End If
    
43.         End If
    
44.         f = Dir
    
45.     Loop
    
46.     Cells.ClearContents
    
47.     [a1].Resize(, n) = ds.keys
    
48.     [a2].Resize(m, n) = brr
    
49.     Application.ScreenUpdating = True
    
50. End Sub

复制代码

zhaogang1960

请看附件
不同格式的多工作薄多工作表的汇总.rar (72.81 KB, 下载次数: 391)

2013-6-29 22:04 上传

点击文件名下载附件

学不完用不尽

各位看官：
您也可以按照您的思路，对“汇总表”工作簿的“合并工作簿”进行设计，总体要求汇总合并后的数据，要能进行数据分析，比如，透视表、sql等

学不完用不尽

zhaogang1960 发表于 2013-6-29 22:05
请看附件

经常看到赵版主您的杰作，谢天谢地，终于得到您的一个答复！感到荣幸！
有个小小的问题，就是要对被合并的工作簿中所有的工作表进行合并汇总。您只汇总了工作簿中的sheet(1)工作表，比如*分公司收支.xls工作簿中的二公司、三公司，没有汇总上。
能否再请您修改下代码，同时考虑一下运行速度问题，我测试了一下，貌似有点慢。

zhaogang1960

学不完用不尽 发表于 2013-6-29 22:32
经常看到赵版主您的杰作，谢天谢地，终于得到您的一个答复！感到荣幸！
有个小小的问题，就是要对被合并 ...

1. Sub Macro1()
   
2.     Dim p$, f$, arr, brr(1 To 60000, 1 To 256), d As Object, ds As Object
   
3.     Dim i&, j, m&, n&, r, y$, sh As Worksheet
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set ds = CreateObject("scripting.dictionary")
   
6.     ds("单位") = 1
   
7.     ds("年") = 2
   
8.     n = 2
   
9.     p = ThisWorkbook.Path & ""
   
10.     f = Dir(p & "*.xls")
    
11.     Application.ScreenUpdating = False
    
12.     Do While f <> ""
    
13.         If f <> ThisWorkbook.Name Then
    
14.             With GetObject(p & f)
    
15.                 For Each sh In .Sheets
    
16.                     arr = sh.[a1].CurrentRegion
    
17.                     If IsArray(arr) Then
    
18.                         y = Left$(f, 4)
    
19.                         For j = 2 To UBound(arr, 2)
    
20.                             If Not ds.Exists(arr(1, j)) Then
    
21.                                 n = n + 1
    
22.                                 ds(arr(1, j)) = n
    
23.                             End If
    
24.                         Next
    
25.                         For i = 2 To UBound(arr)
    
26.                             s = arr(i, 1) & Chr(9) & y & Chr(9) & arr(i, 2) & Chr(9) & arr(i, 3)
    
27.                             r = d(s)
    
28.                             If r = "" Then
    
29.                                 m = m + 1
    
30.                                 d(s) = m
    
31.                                 brr(m, 1) = arr(i, 1)
    
32.                                 brr(m, 2) = y
    
33.                                 For j = 2 To UBound(arr, 2)
    
34.                                     brr(m, ds(arr(1, j))) = arr(i, j)
    
35.                                 Next
    
36.                             Else
    
37.                                 For j = 4 To UBound(arr, 2)
    
38.                                     brr(r, ds(arr(1, j))) = brr(r, ds(arr(1, j))) + arr(i, j)
    
39.                                 Next
    
40.                             End If
    
41.                         Next
    
42.                     End If
    
43.                 Next
    
44.                 .Close False
    
45.             End With
    
46.         End If
    
47.         f = Dir
    
48.     Loop
    
49.     Cells.ClearContents
    
50.     [a1].Resize(, n) = ds.keys
    
51.     [a2].Resize(m, n) = brr
    
52.     Application.ScreenUpdating = True
    
53. End Sub
    
54. 
    
55. 
    

复制代码

excel好玩

学不完用不尽 发表于 2013-6-29 22:32
经常看到赵版主您的杰作，谢天谢地，终于得到您的一个答复！感到荣幸！
有个小小的问题，就是要对被合并 ...

1. Sub hebing()
   
2.     Dim Mysht As Worksheet, sht As Worksheet, k%, p$, f$, i%, j%
   
3.     Dim Brr(1 To 60000, 1 To 28), Arr, dTitle
   
4.     Set Mysht = ActiveSheet
   
5.     Set dTitle = CreateObject("scripting.dictionary")
   
6.     k = 1
   
7.     Application.ScreenUpdating = False
   
8.     For i = 1 To UBound(Brr, 2)
   
9.         dTitle(Cells(1, i).Value) = i
   
10.     Next
    
11.     p = ThisWorkbook.Path
    
12.     f = Dir(p & "\*.xls")
    
13.     Do While Len(f) > 0
    
14.         If f <> ThisWorkbook.Name Then
    
15.             With CreateObject(p & "" & f)
    
16.                 For Each sht In .Sheets
    
17.                     If sht.[a1] <> "" Then
    
18.                         Arr = sht.[a1].CurrentRegion
    
19.                         For i = 2 To UBound(Arr)
    
20.                             For j = 1 To UBound(Arr, 2)
    
21.                                 Brr(k, dTitle(Arr(1, j))) = Arr(i, j)
    
22.                                 Brr(k, 2) = Left(.Name, 4)
    
23.                             Next
    
24.                             k = k + 1
    
25.                         Next
    
26.                     End If
    
27.                 Next
    
28.                 .Close False
    
29.             End With
    
30.         End If
    
31.         f = Dir
    
32.     Loop
    
33.     Range("a2:az60000").ClearComments
    
34.     Mysht.[a2].Resize(k - 1, 28) = Brr
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    
37. 
    

复制代码

zhaogang1960

请看附件
不同格式的多工作薄多工作表的汇总.rar (86.74 KB, 下载次数: 345)

2013-6-30 00:45 上传

点击文件名下载附件

学不完用不尽

zhaogang1960 发表于 2013-6-29 22:40
请看附件

看来我在5楼的要求，让赵版主误会了，恕我表达不清，其实我的真实意图是只汇总不求和。
另外再对“合并工作簿”工作表的数据再处理（这是另外一个程序，需要在另外一个表中处理）。