如何把多个工作簿的数据快速汇总至一个工作簿中?

rclyyh

我要统计下属20余个单位的数据。
现在我把数据表工作簿（格式相同）下发给每个单位，让他们自己填写数据，然后由他们传给我，我集中收集后再进行统计。
我的问题是：（1）手工统计肯定不科学，笨也累；
（2）把其他工作簿中的数据全部粘贴至我的汇总工作簿中（格式相同），再用公式进行相加操作。这个方法到可行，但要复制粘贴20余下，也累得够呛。
想问老师：有没有什么办法，能够把下属单位报上来的数据（相同格式）快速统计到我的汇总工作簿来（格式同样的都一样）。

LangQueS

http://club.excelhome.net/dispbbs.asp?boardid=2&ID=336289

sea2008

传个附件，用透视表可以做

rclyyh

见附件，快速统计单位1，2，3数据至“汇总表”，几个表格式全相同

zlm2002

哈哈我也用得上

jiminyanyan

代码放到汇总表中。

1. Sub huizong()
   
2.     Dim s
   
3.     Dim irow&, k&
   
4.     Dim sht As Worksheet, Nsht As Worksheet
   
5.     Dim wb As Workbook, th As Workbook    '定义详细的变量类型，可以提高代码的速度
   
6. 
   
7.     Set th = ThisWorkbook
   
8.     Application.ScreenUpdating = False
   
9.     th.Sheets("Sheet1").Range("B2:c5").ClearContents    '先要清除掉各工作表相应区域的内容
   
10.   
    
11.     With Application.FileSearch    '建立一个对文件的查询
    
12.         .NewSearch
    
13.         .LookIn = th.Path    '搜索范围为本工作簿的路径下
    
14.         .Filename = "*.xls"    '搜索所有的xls文件
    
15.         .Execute    '执行这个搜索
    
16. 
    
17.         For Each s In .FoundFiles    '在每一个搜索的工作簿里循环
    
18.             If s <> th.FullName Then    '如果搜索到工作簿名称不为本工作簿
    
19.                 Set wb = Workbooks.Open(s)    '设置一个变量来代替这个新打开工作簿
    
20. 
    
21.                 For Each sht In th.Sheets    '在工作表里循环
    
22.                     If sht.Name <> th.Name Then    '假如工作表不为“汇总表代码”，则
    
23.                         If Testsht(sht.Name, wb) Then    '测试工作表在新的工作薄里有没有，如果有，则执行下面的拷贝数据
    
24.                             If sht.Name = "Sheet1" Then    '针对每一个表，复制的区域不一致
    
25.                                 wb.Sheets("Sheet1").Range("B2:c5").Copy    '复制数据区域
    
26.                                 th.Sheets("Sheet1").Range("B2:c5").PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
    
27.         :=False, Transpose:=False
    
28.                             End If
    
29.                         End If
    
30.                     End If
    
31.                 Next
    
32.                 wb.Close False    '最后关闭打开的工作簿
    
33.             End If
    
34.         Next
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "数据已汇总完毕！"
    
38. End Sub
    
39. '这是一个自定义函数，用于判断一个工作表是否存在在其他工作薄的表里，此函数被接收汇总过程调用。
    
40. Function Testsht(shtname As String, wb As Workbook) As Boolean
    
41.     Dim s As String
    
42.     On Error GoTo line1
    
43.     s = wb.Sheets(shtname).Name    '选择工作表，如果可以选择的话就是true，然后退出
    
44.     Testsht = True
    
45.     Exit Function
    
46. line1:
    
47.     Testsht = False    '如果工作表不存在，则会跳转到line1这里，即为false
    
48. End Function
    

复制代码

jiminyanyan

再搞一个方法，坛子里的代码组装一下。

1. Sub hz_2()
   
2.     Dim Fso, Fld, Fl
   
3.     Dim arr, brr(1 To 4, 1 To 2), i%, j%
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set Fld = Fso.getfolder(ThisWorkbook.Path & "\数据")
   
6.     If Fld.Files.Count > 0 Then
   
7.         Application.ScreenUpdating = False
   
8.         For Each Fl In Fld.Files
   
9.             Workbooks.Open (Fl)
   
10.             arr = ActiveWorkbook.Worksheets(1).[B2:c5] '各表数据域赋给数组arr
    
11.             For i = 1 To 4 '逐行
    
12.                 For j = 1 To 2 '逐列
    
13.                     If IsNumeric(arr(i, j)) Then brr(i, j) = brr(i, j) + arr(i, j) '如果单元格是数字则累加
    
14.                 Next
    
15.             Next
    
16.             ActiveWorkbook.Close
    
17.         Next
    
18.         Application.ScreenUpdating = True
    
19.         ThisWorkbook.Worksheets(1).[B2:c5] = brr '写数据
    
20.         MsgBox "数据汇总完成"
    
21.     Else
    
22.         MsgBox "没有找到任何工作簿文件"
    
23.     End If
    
24. 
    
25. End Sub
    
26. 
    

复制代码

rclyyh

jiminyanyan朋友,很好很强大

沧海一粒沙

小白  弄不懂  你的附件就几个表格？？

kszcs

jiminyanyan 发表于 2010-11-23 20:17
代码放到汇总表中。

这个代码为什么不能执行？
子过程或函数未定义