求教：多个工作簿里多个工作表汇总到1个工作簿里，每个工作表里进行累加

yefan666

前辈们好，

请教如何写一段VBA代码，把 多个工作簿里多个工作表（格式相同）汇总到1个工作簿里，在新工作簿里的工作表总数不变，每个新工作表是相对应的工作表的累加.

请查看附件，我想要到达汇总工作簿里那样的效果。

试了好久，仍没成功

十分谢谢!!!! 汇总求教.zip (87.42 KB, 下载次数: 45)

2015-1-7 06:44 上传

点击文件名下载附件
示例文件

feiren228

搜索下遍历的帖子，有很多。档案1问卷4格式不一样

mmwwdd

你的表的格式不一样，不好做

mmwwdd

给你编了，但你行的重复项也很多，都是英语的，本人英语是弱项,呵呵

mmwwdd

1. Sub Macro1()
   
2. Dim j As Integer
   
3.     Dim MyPath$, MyName$, wb As Workbook, sh As Worksheet, d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set wb = ThisWorkbook
   
8.     MyPath = ThisWorkbook.Path & "\汇总求教"
   
9.             
   
10.     MyName = Dir(MyPath & "*.xls")
    
11.       
    
12.     Do While MyName <> ""
    
13.         With GetObject(MyPath & MyName)
    
14.             For Each sh In .Sheets
    
15.             
    
16.                 With sh
    
17.                        j = .Range("A65536").End(xlUp).Row
    
18.                        l = .Cells(1, Columns.Count).End(xlToLeft).Column
    
19.                        arr = .Range(.Cells(1, 1), .Cells(j, l))
    
20.                        For i = 2 To UBound(arr)
    
21.                            For l = 2 To UBound(arr, 2)
    
22.                            d(arr(i, 1) & arr(1, l)) = arr(i, l)
    
23.                            Next
    
24.                        Next
    
25.                        With ThisWorkbook.Sheets(.Name)
    
26.                          j = .Range("A65536").End(xlUp).Row
    
27.                         l = .Cells(1, Columns.Count).End(xlToLeft).Column
    
28.                        brr = .Range(.Cells(1, 1), .Cells(j, l))
    
29.                        For i = 2 To UBound(brr)
    
30.                            For k = 2 To UBound(brr, 2)
    
31.                            d(brr(i, 1) & brr(1, k)) = d(brr(i, 1) & brr(1, k)) + brr(i, k)
    
32.                            brr(i, k) = d(brr(i, 1) & brr(1, k))
    
33.                            Next
    
34.                        Next
    
35.                         
    
36.                         .[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
    
37.                   
    
38.                        End With
    
39. '
    
40.                 End With
    
41.                Erase arr: Erase brr
    
42.             Next
    
43.             
    
44.             .Close False
    
45.         End With
    
46.         MyName = Dir
    
47.     Loop
    
48.     Sheets(1).Activate
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "ok"
    
51. End Sub

复制代码

给你贴一小段程序，仅供参考，思路就是这样的，但不能用在本文件上！！