请大神帮忙 vba 汇总统计

yaohyong

将各分部的数据 汇总统计到汇总表

详细数据有天津上海北京  等数据表

表的标题都是一样的

效果：1.将目录下面的所有excel表格 合到汇总一个工作簿 其它表名称同原来工作簿名称代替
           2.统计分表中所有型号每周数量和 如k305 第一周入多少之和

yaohyong

Sub 考勤汇总()
Dim arr As Variant
Dim d, d1 As Object
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("scripting.dictionary")
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name <> "汇总" Then
arr = sh.Range("a4").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)
d1(arr(i, 1)) = d1(arr(i, 1)) + arr(i, 3)
Next
End If
With Sheets("汇总")
.Rows("4:5000").ClearContents
.Columns(1).Cells(.Columns(1).Cells.Count).End(xlUp).Offset(1).Resize(d.Count, 1) = Application.Transpose(d.keys)
.Columns(2).Cells(.Columns(2).Cells.Count).End(xlUp).Offset(1).Resize(d.Count, 1) = Application.Transpose(d.items)
.Columns(3).Cells(.Columns(3).Cells.Count).End(xlUp).Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.items)
End With
Next
End Sub
这个代码 那个大师帮忙改下  

grf1973

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim brr(1 To 1000, 1 To 15)
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Do While Filename <> ""
   
8.         If Filename <> ThisWorkbook.Name Then
   
9.             fn = ThisWorkbook.Path & "" & Filename
   
10.             Set wb = Workbooks.Open(fn)
    
11.             wb.Worksheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
12.             With ActiveSheet
    
13.                 .Name = Split(wb.Name, ".")(0)
    
14.                 r = .[a65536].End(3).Row
    
15.                 If r >= 4 Then
    
16.                     arr = .Range("a4:o" & .[a65536].End(3).Row)
    
17.                     For i = 1 To UBound(arr)
    
18.                         x = arr(i, 1)
    
19.                         If Len(x) > 0 Then
    
20.                             If Not d.exists(x) Then
    
21.                                 n = n + 1
    
22.                                 d(x) = n
    
23.                                 brr(n, 1) = x
    
24.                             End If
    
25.                             p = d(x)
    
26.                             For j = 2 To UBound(arr, 2)
    
27.                                 If arr(i, j) <> 0 Then brr(p, j) = brr(p, j) + arr(i, j)
    
28.                             Next
    
29.                         End If
    
30.                     Next
    
31.                 End If
    
32.             End With
    
33.             wb.Close False
    
34.         End If
    
35.         Filename = Dir
    
36.     Loop
    
37.     Set Sht = Nothing
    
38.     With Sheet1
    
39.         .[a4:o1000].ClearContents
    
40.         .[a4].Resize(n, 15) = brr
    
41.         .Activate
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44. End Sub

复制代码

yaohyong

grf1973 发表于 2016-2-25 10:48

  感谢  感谢  感谢 ！

yaohyong

test.zip (71.43 KB, 下载次数: 4)

2016-2-25 12:39 上传

点击文件名下载附件 grf1973 发表于 2016-2-25 10:48

如果数据行中有公式想跳过这行
比如不计算海口1表中176行
应该怎么做呢

grf1973

加个判断，把A列含“计”的去掉。

yaohyong

grf1973 发表于 2016-2-25 13:23
加个判断，把A列含“计”的去掉。

{:1112:}  谢谢