1-12月 不同表头标题（字段）数据合并(非常感谢zhaogang1960等老师)

blackttea1

非常感谢！

yangkd

高人啊   求救啦  多次求解无果啦  要求见说明  谢谢！
http://club.excelhome.net/thread-734087-1-1.html

kszcs

zhaogang1960 发表于 2011-6-26 22:08
没有问题，不过这样一来第一、二列要求写工作簿、工作表名就没有意义了，下面代码已经把这个功能注释化了 ...

赵老师你好：
这个簿中的表没有完全汇总上，麻烦看看
谢谢！

zhaogang1960

kszcs 发表于 2012-1-7 08:15
赵老师你好：
这个簿中的表没有完全汇总上，麻烦看看
谢谢！

我已经忘记这个题目的具体要求了，还是说出你有什么要求吧

kszcs

zhaogang1960 发表于 2012-1-7 14:40
我已经忘记这个题目的具体要求了，还是说出你有什么要求吧

最初的回复是在16楼，目的是把“数据源”文件夹内所有工作簿中所有的表汇集在一起，表头自动筛选出所有表的不重复的放在汇总表。（横向表头不重复，竖向一列的姓名各表按顺序放在一个表，有重复）
在22楼的回复是要求横向的表头不重复，一列（“数据源”中表的C列姓名）姓名也不重复；相同的数据合计在一起。
问题：代码在22楼好使，在这里怎么不好使

zhaogang1960

kszcs 发表于 2012-1-7 15:59
最初的回复是在16楼，目的是把“数据源”文件夹内所有工作簿中所有的表汇集在一起，表头自动筛选出所有表 ...

1. Sub Macro1()
   
2.     Dim arrpath$(), arr, brr(), sh As Worksheet, i&, j&, m&, n&, k&, d As Object, ds As Object
   
3.     Dim myPath$, myFile$, wb As Workbook, s$, w$
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set ds = CreateObject("scripting.dictionary")
   
6. '    d("工作簿") = 1
   
7. '    d("工作表") = 2
   
8. '    m = 2
   
9.     Set wb1 = ThisWorkbook
   
10.     Application.ScreenUpdating = False
    
11.     myPath = ThisWorkbook.Path & "\数据源"
    
12.     myFile = Dir(myPath & "*.xls")
    
13.     Do While myFile <> ""
    
14.             n = n + 1 '工作簿计数
    
15.             ReDim Preserve arrpath(1 To n) '重新定义工作簿路径数组
    
16.             arrpath(n) = myPath & myFile '记录工作簿路径
    
17.             Set wb = GetObject(arrpath(n)) '调用这个工作簿
    
18.             For Each sh In wb.Sheets
    
19.                 With sh
    
20.                     If IsSheetEmpty = IsEmpty(.UsedRange) Then
    
21.                         arr = .[b3].Resize(.[b65536].End(xlUp).Row - 2, .[iv3].End(xlToLeft).Column - 1)
    
22.                         For j = 1 To UBound(arr, 2)
    
23.                             If Not d.Exists(arr(1, j)) Then
    
24.                                 m = m + 1
    
25.                                 d(arr(1, j)) = m
    
26.                             End If
    
27.                         Next
    
28.                     End If
    
29.                 End With
    
30.             Next
    
31.             wb.Close False
    
32.         myFile = Dir
    
33.     Loop
    
34.     ReDim brr(1 To 60000, 1 To d.Count)
    
35.     m = 0
    
36.     For k = 1 To n '逐个工作簿
    
37. '        w = Split(Split(arrpath(k), "")(UBound(Split(arrpath(k), ""))), ".")(0)
    
38.         Set wb = GetObject(arrpath(k)) '调用工作簿
    
39.         For Each sh In wb.Sheets
    
40.             With sh
    
41.                 If IsSheetEmpty = IsEmpty(.UsedRange) Then
    
42. '                    s = .Name
    
43.                     arr = .[b3].Resize(.[b65536].End(xlUp).Row - 2, .[iv3].End(xlToLeft).Column - 1)
    
44.                     For i = 2 To UBound(arr)
    
45.                         If Len(arr(i, 1)) > 0 And arr(i, 1) <> "合计" Then
    
46.                             If Not ds.Exists(arr(i, 1)) Then
    
47.                                 m = m + 1
    
48.                                 ds(arr(i, 1)) = m
    
49.     '                            brr(m, 1) = w
    
50.     '                            brr(m, 2) = s
    
51.                                 For j = 1 To UBound(arr, 2)
    
52.                                     brr(m, d(arr(1, j))) = arr(i, j)
    
53.                                 Next
    
54.                             Else
    
55.                                 For j = 3 To UBound(arr, 2)
    
56.                                     brr(ds(arr(i, 1)), d(arr(1, j))) = brr(ds(arr(i, 1)), d(arr(1, j))) + arr(i, j)
    
57.                                 Next
    
58.                             End If
    
59.                         End If
    
60.                     Next
    
61.                 End If
    
62.             End With
    
63.         Next
    
64.         wb.Close False
    
65.     Next
    
66.     ActiveSheet.UsedRange.ClearContents
    
67.     [a1].Resize(, d.Count) = d.Keys
    
68.     [a2].Resize(m, d.Count) = brr
    
69.     Application.ScreenUpdating = True
    
70.     MsgBox "汇总完毕"
    
71. End Sub
    
72. 
    

复制代码

jygzcj

字典,数组,速度是相当的快啊!

kszcs

zhaogang1960 发表于 2012-1-7 16:25

如果不限于“数据源”文件夹，用选择文件夹可以吗

zhaogang1960

kszcs 发表于 2012-1-7 16:44
如果不限于“数据源”文件夹，用选择文件夹可以吗

没有汇总完全.rar (42.13 KB, 下载次数: 156)

2012-1-7 16:59 上传

点击文件名下载附件

kszcs

zhaogang1960 发表于 2012-1-7 16:59

谢谢赵老师！
这个代码就是一个非常实用的工具