多个工作簿同名工作表数据汇总

晓兰jojo

我有很多工作簿（100多个），如店铺1,2，每个工作簿下面有多个工作表，名称都一样，就是行数都不同。想通过Excel汇总成目标表，请大侠帮忙解答。急

wangjguo44

听起来似乎可用SUM+SUMIF+INDIRECT，但不见附件不敢断言

求助excel问题，如果仅仅用文字叙述要求，容易引起歧义，没有表格没有单元格地址，无法编写公式。而若光是截图，截图是死数据，无法提取，一个个数据“剥”到表格里，需要花相当长时间，也不一定能复原成你的现成表。你若已有excel表格，直接压缩上传，与人方便就是与己方便。
请养成随帖上传excel压缩附件的习惯，有表格、有数据、有要求、有说明，还有手工模拟结果（甚至比较难理解的还对结果的得到做些解释），这样往往能快速有效地得到解答帮助。

看见星光

不同的工作薄，最好用VBA或SQL解决，函数跨工作薄很憋屈。

晓兰jojo

wangjguo44 发表于 2016-3-8 08:43
听起来似乎可用SUM+SUMIF+INDIRECT，但不见附件不敢断言

求助excel问题，如果仅仅用文字叙述要求，容易 ...

详情见附件，忘了上传了

看见星光

1. Sub tt()
   
2. Dim sht As Worksheet, p$, f$, d As Object, arr, brr, i&, j&, k&
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. Set d = CreateObject("scripting.dictionary")
   
6. For Each sht In Worksheets
   
7.     If sht.Name <> ActiveSheet.Name Then sht.Delete
   
8. Next
   
9. Set sh = ActiveSheet
   
10. ReDim brr(1 To Cells.Rows.Count, 1 To 20)
    
11. p = ThisWorkbook.Path & ""
    
12. f = Dir(p & "*.xls")
    
13. Do While f <> ""
    
14.     If f <> ThisWorkbook.Name Then
    
15.         With GetObject(p & f)
    
16.             For Each sht In .Worksheets
    
17.                 shtname = sht.Name
    
18.                 arr = sht.[a1].CurrentRegion
    
19.                 For i = 2 To UBound(arr)
    
20.                     k = k + 1
    
21.                     For j = 1 To UBound(arr, 2)
    
22.                         brr(k, j) = arr(i, j)
    
23.                     Next
    
24.                     brr(k, UBound(arr, 2) + 1) = Split(f, ".xls")(0)
    
25.                     If Not d.exists(shtname) Then
    
26.                         Set d(shtname) = CreateObject("scripting.dictionary")
    
27.                         For n = 1 To UBound(arr, 2)
    
28.                             s = s & "," & arr(1, n)
    
29.                         Next
    
30.                         d(shtname)(shtname) = Mid(s, 2)
    
31.                         s = ""
    
32.                     End If
    
33.                     d(shtname)(k) = ""
    
34.                 Next
    
35.             Next
    
36.             .Close False
    
37.         End With
    
38.     End If
    
39.     f = Dir()
    
40. Loop
    
41. kr = d.keys
    
42. For i = 0 To UBound(kr)
    
43.     With Worksheets.Add(, Sheets(Sheets.Count))
    
44.         .Name = kr(i)
    
45.         r = d(kr(i)).keys
    
46.         ReDim drr(1 To UBound(r) + 1, 1 To UBound(brr, 2))
    
47.         For x = 0 To UBound(r)
    
48.             If r(x) <> kr(i) Then
    
49.                 For y = 1 To UBound(brr, 2)
    
50.                     drr(x, y) = brr(r(x), y)
    
51.                 Next
    
52.             End If
    
53.         Next
    
54.         ar = Split(d(kr(i))(kr(i)), ",")
    
55.         .[a1].Resize(1, UBound(ar) + 1) = ar
    
56.         .[a2].Resize(UBound(r) + 1, UBound(brr, 2)) = drr
    
57.     End With
    
58. Next
    
59. sh.Activate
    
60. Set d = Nothing
    
61. Application.ScreenUpdating = True
    
62. Application.DisplayAlerts = True
    
63. End Sub
    

复制代码

看见星光

假设不知道分表的名称，由代码自动提取，并合并。
附件参考：
新建文件夹.zip (36.9 KB, 下载次数: 265)

2016-3-8 13:12 上传

点击文件名下载附件

晓兰jojo

看见星光 发表于 2016-3-8 13:12
假设不知道分表的名称，由代码自动提取，并合并。
附件参考：

显示  运行时错误‘7’：内存溢出  
小白实在不懂，请大侠不吝指教

看见星光

晓兰jojo 发表于 2016-3-8 15:13
显示  运行时错误‘7’：内存溢出  
小白实在不懂，请大侠不吝指教

新建文件夹.zip (36.27 KB, 下载次数: 552)

2016-3-8 15:16 上传

点击文件名下载附件

我把brr定的太大了，附件修了一下，可以再测试看看

晓兰jojo

看见星光 发表于 2016-3-8 15:17
我把brr定的太大了，附件修了一下，可以再测试看看

谢谢大侠，能运行了

netbug1972

看见星光 发表于 2016-3-8 13:12
假设不知道分表的名称，由代码自动提取，并合并。
附件参考：

如果分表的名称是固定的,比如 AAA
这个时候代码应该如何改呢?