同个文件夹里的工作簿怎样进行汇总？

刘圳峰

11.rar (12.78 KB, 下载次数: 52)

2016-1-5 18:50 上传

点击文件名下载附件

LangQueS

将以将基础数据保存在同一个工作表中

关于使用Excel管理数据的基本方法请参考：
  
★Excel数据管理的一般规律★    http://club.excelhome.net/thread-287461-1-1.html

zhaogang1960

请参考:

1. Sub Macro1()
   
2.     Dim MyPath$, MyName$, arr, brr(1 To 60000, 1 To 7), i&, j&, m&, d As Object
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     MyPath = ThisWorkbook.Path & ""
   
6.     MyName = Dir(MyPath & "*.xls")
   
7.     Do While MyName <> ""
   
8.         If MyName <> ThisWorkbook.Name Then
   
9.             With GetObject(MyPath & MyName)
   
10.                 arr = .Sheets(1).[a1].CurrentRegion
    
11.                 .Close False
    
12.             End With
    
13.             For i = 3 To UBound(arr)
    
14.                 r = d(arr(i, 1))
    
15.                 If r = "" Then
    
16.                     m = m + 1
    
17.                     d(arr(i, 1)) = m
    
18.                     For j = 1 To 7
    
19.                         brr(m, j) = arr(i, j)
    
20.                     Next
    
21.                 Else
    
22.                     For j = 2 To 7
    
23.                         brr(r, j) = brr(r, j) + arr(i, j)
    
24.                     Next
    
25.                 End If
    
26.             Next
    
27.         End If
    
28.         MyName = Dir
    
29.     Loop
    
30.     [a1].CurrentRegion.Offset(2).ClearContents
    
31.     [a3].Resize(m, 7) = brr
    
32.     Application.ScreenUpdating = True
    
33. End Sub
    

复制代码

zhaogang1960

请测试附件
11.rar (19.56 KB, 下载次数: 87)

2016-1-5 21:42 上传

点击文件名下载附件

JJMY

zhaogang1960 发表于 2016-1-5 21:42
请测试附件

如果源表的数据不规范，列数不一，能达到汇总的效果吗

LMY123

1. Sub 同夹_多薄_首表_汇总成一薄一表_A列分类_BCDEFG列分别汇总_字典法() '''已入代码宝库
   
2.     Dim 结果数组(1 To 60000, 1 To 7)
   
3.     Application.ScreenUpdating = False
   
4.     Set 字典 = CreateObject("scripting.dictionary")
   
5.     路径 = ThisWorkbook.Path & ""
   
6.     外薄 = Dir(路径 & "*.xls")
   
7.     Do While 外薄 <> ""
   
8.         If 外薄 <> ThisWorkbook.Name Then
   
9.             With GetObject(路径 & 外薄)
   
10.                 外数组 = .Sheets(1).[a1].CurrentRegion
    
11.                 .Close False
    
12.             End With
    
13.             For 行 = 3 To UBound(外数组)
    
14.                 字典行 = 字典(外数组(行, 1))
    
15.                 If 字典行 = "" Then
    
16.                     计数器 = 计数器 + 1
    
17.                     字典(外数组(行, 1)) = 计数器
    
18.                     For 列 = 1 To 7
    
19.                         结果数组(计数器, 列) = 外数组(行, 列)
    
20.                     Next 列
    
21.                 Else
    
22.                     For 列 = 2 To 7
    
23.                         结果数组(字典行, 列) = 结果数组(字典行, 列) + 外数组(行, 列)
    
24.                     Next 列
    
25.                 End If
    
26.             Next 行
    
27.         End If
    
28.         外薄 = Dir
    
29.     Loop
    
30.     [a1].CurrentRegion.Offset(2).ClearContents
    
31.     [a3].Resize(计数器, 7) = 结果数组
    
32.     Application.ScreenUpdating = True
    
33. End Sub
    
34. Sub 同夹_多薄_首表_合并成一薄一表_字典法() '''已入代码宝库
    
35.     Dim 结果数组(1 To 60000, 1 To 7)
    
36.     Application.ScreenUpdating = False
    
37.     Set 字典 = CreateObject("scripting.dictionary")
    
38.     路径 = ThisWorkbook.Path & ""
    
39.     外薄 = Dir(路径 & "*.xls")
    
40.     Do While 外薄 <> ""
    
41.         If 外薄 <> ThisWorkbook.Name Then
    
42.             With GetObject(路径 & 外薄)
    
43.                 外数组 = .Sheets(1).[a1].CurrentRegion
    
44.                 .Close False
    
45.             End With
    
46.             For 行 = 3 To UBound(外数组)
    
47.                     计数器 = 计数器 + 1
    
48.                     For 列 = 1 To 7
    
49.                         结果数组(计数器, 列) = 外数组(行, 列)
    
50.                     Next 列
    
51.             Next 行
    
52.         End If
    
53.         外薄 = Dir
    
54.     Loop
    
55.     [a1].CurrentRegion.Offset(2).ClearContents
    
56.     [a3].Resize(计数器, 7) = 结果数组
    
57.     Application.ScreenUpdating = True
    
58. End Sub

复制代码

jjmysjg

LMY123 发表于 2019-1-1 16:02

代码中的汉子？