如何提取同一文件夹下不同工作薄的相同单元格内容,并把求和的值写入汇总表

晨风行舟

如何提取同一文件夹下不同工作薄的相同单元格内容,并把相同内容的单元格所在行后面的单元格进行汇总求和,主要问题是行数不一定,有时多有时少,列数一致,内容见附件





样表.rar (48.13 KB, 下载次数: 29)

2016-7-20 10:59 上传

点击文件名下载附件

Chip_Kenny

Try this:

1. Sub zz()
   
2.     Dim p$, f$, i&, j&, ar, d As Object, k, t
   
3.     Application.ScreenUpdating = False
   
4.     Application.ShowWindowsInTaskbar = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     p = ThisWorkbook.Path & "\k"
   
7.     f = Dir(p & "*.xlsx")
   
8.     Do While f <> ""
   
9.         Workbooks.Open (p & f)
   
10.             ar = Sheets(1).UsedRange
    
11.             Workbooks(f).Close 0
    
12.                 For i = 2 To UBound(ar)
    
13.                     For j = 2 To UBound(ar, 2)
    
14.                         If Not d.exists(ar(i, 2)) Then
    
15.                             d(ar(i, 2)) = Array(ar(i, 3), ar(i, 4), ar(i, 5), ar(i, 6))
    
16.                         Else
    
17.                             t = d(ar(i, 2))
    
18.                             d(ar(i, 2)) = Array(ar(i, 3), ar(i, 4) + t(1), ar(i, 5) + t(2), ar(i, 6) + t(3))
    
19.                         End If
    
20.                     Next
    
21.                 Next
    
22.         f = Dir
    
23.     Loop
    
24.     If d.Count Then
    
25.         k = d.keys: t = d.items
    
26.         ReDim ar(1 To d.Count, 1 To 5)
    
27.         For i = 0 To UBound(k)
    
28.             ar(i + 1, 1) = k(i)
    
29.             For j = 0 To UBound(t(i))
    
30.                 ar(i + 1, j + 2) = t(i)(j)
    
31.             Next
    
32.         Next
    
33.         [b2:f65536] = ""
    
34.         [b2].Resize(d.Count, 1).NumberFormat = "@"
    
35.         [b2].Resize(d.Count, 5) = ar
    
36.     End If
    
37.     Application.ScreenUpdating = True
    
38.     Application.ShowWindowsInTaskbar = True
    
39. End Sub

复制代码

晨风行舟

上面这段代码好象d的值只能是256个,多了就不行了,代码出错,平常表的行数都是很多的,代码数肯定会超过256个的

d(ar(i, 2)) = Array(ar(i, 3), ar(i, 4) + t(1), ar(i, 5) + t(2), ar(i, 6) + t(3))

还是有别的原因?我把样表搞复杂了,再上传一下附件

样表2.rar (237.84 KB, 下载次数: 36)

2016-7-20 14:50 上传

点击文件名下载附件

云開月明

我下载也试验，运行代码出现
d(ar(i, 2)) = Array(ar(i, 3), ar(i, 4) + t(1), ar(i, 5) + t(2), ar(i, 6) + t(3))
类型不匹配？
请高手指教

补充内容 (2016-11-16 21:12):
20161年11月16日又下载实验，应该确定20160107.xlsx文件中第273列号的数据有问题，导致数据无法累加，提示数据类型不匹配。
我增加一条语句"on error resume next"加以容错，可以顺畅运行并且汇总。
我知道肯定...。

masterswx

学习一下！！

xzcdcak

为什么我运行上面的代码它什么也不做呢？

Chip_Kenny

file 20160105 變了文本了, 將第18行代碼改一下便可。

1. Sub zz()
   
2.     Dim p$, f$, i&, j&, ar, d As Object, k, t
   
3.     Application.ScreenUpdating = False
   
4.     Application.ShowWindowsInTaskbar = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     p = ThisWorkbook.Path & "\k"
   
7.     f = Dir(p & "*.xlsx")
   
8.     Do While f <> ""
   
9.         Workbooks.Open (p & f)
   
10.             ar = Sheets(1).UsedRange
    
11.             Workbooks(f).Close 0
    
12.                 For i = 2 To UBound(ar)
    
13.                     For j = 2 To UBound(ar, 2)
    
14.                         If Not d.exists(ar(i, 2)) Then
    
15.                             d(ar(i, 2)) = Array(ar(i, 3), ar(i, 4), ar(i, 5), ar(i, 6))
    
16.                         Else
    
17.                             t = d(ar(i, 2))
    
18.                             d(ar(i, 2)) = Array(ar(i, 3), ar(i, 4) + Val(t(1)), ar(i, 5) + Val(t(2)), ar(i, 6) + Val(t(3)))
    
19.                         End If
    
20.                     Next
    
21.                 Next
    
22.         f = Dir
    
23.     Loop
    
24.     If d.Count Then
    
25.         k = d.keys: t = d.items
    
26.         ReDim ar(1 To d.Count, 1 To 5)
    
27.         For i = 0 To UBound(k)
    
28.             ar(i + 1, 1) = k(i)
    
29.             For j = 0 To UBound(t(i))
    
30.                 ar(i + 1, j + 2) = t(i)(j)
    
31.             Next
    
32.         Next
    
33.         [b2:f65536] = ""
    
34.         [b2].Resize(d.Count, 1).NumberFormat = "@"
    
35.         [b2].Resize(d.Count, 5) = ar
    
36.     End If
    
37.     Application.ScreenUpdating = True
    
38.     Application.ShowWindowsInTaskbar = True
    
39. End Sub

复制代码

Chip_Kenny

回复了但需要审核，请等待通过