[已解决]按工作薄名称提取数值

salt

如何用宏将45和114文件夹里工作薄里的汇总表数据的合计列按工作薄名称提取到汇总表里,求求各位老师帮帮忙，感激不尽。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-20 11:43

表格行行对应，删除字典，直接汇总

跳转到最佳答案楼层

爱疯

汇总就是加到一起吗？

salt

爱疯 发表于 2014-12-19 23:12
汇总就是加到一起吗？

我想要合计列里的所有数据根据汇总表里对应的工作薄名称复制，方便汇总数据

668zqh

爱疯 发表于 2014-12-19 23:12
汇总就是加到一起吗？

谢谢了1好东西啊！！！赞一个

dsmch

1. Dim w(1 To 10000), s%
   
2. Sub Macro1()
   
3. Dim arr, brr, crr, wb As Workbook, d, i&, j&, k%
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Range("a3:d" & Range("a65536").End(xlUp).Row)
   
6. s = 0
   
7. For i = 2 To UBound(arr)
   
8.     p2 = ""
   
9.     For j = 2 To UBound(arr, 2)
   
10.         p2 = p2 & "," & Trim(arr(i, j))
    
11.     Next
    
12.     d(p2) = i
    
13. Next
    
14. zdir ThisWorkbook.Path & "\数据源"
    
15. ReDim brr(1 To UBound(arr), 1 To s)
    
16. Application.ScreenUpdating = False
    
17. For i = 1 To s
    
18.     Set wb = GetObject(w(i))
    
19.     crr = wb.Sheets("汇总表").UsedRange
    
20.     wb.Close 0
    
21.     x = Split(w(i), "")
    
22.     brr(1, i) = Replace(x(UBound(x)), ".xls*", "")
    
23.     For j = 4 To UBound(crr)
    
24.         p2 = ""
    
25.         For k = 2 To 4
    
26.             p2 = p2 & "," & Trim(crr(j, k))
    
27.         Next
    
28.         If d.Exists(p2) Then brr(d(p2), i) = crr(j, 10)
    
29.     Next
    
30. Next
    
31. Range("e3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
32. Application.ScreenUpdating = True
    
33. End Sub
    
34. Sub zdir(p)
    
35. Dim fs As New FileSystemObject
    
36. For Each f In fs.GetFolder(p).Files
    
37.     If f Like "*.xls*" Then s = s + 1: w(s) = f
    
38. Next
    
39. For Each m In fs.GetFolder(p).SubFolders
    
40.     zdir m
    
41. Next
    
42. End Sub

复制代码

dsmch

要汇总的工作簿放在同一文件夹下，方便汇总

salt

dsmch 发表于 2014-12-20 06:39
要汇总的工作簿放在同一文件夹下，方便汇总

麻烦老师能再改一下吗！提取值后自动在最后列添加合计，谢谢！

dsmch

表格行行对应，删除字典，直接汇总