Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2486|回复: 3

[已解决]同时提取文件夹里工作薄和仓库出库结算汇总表里的数据

[复制链接]
发表于 2014-12-25 11:52 | 显示全部楼层 |阅读模式
本帖最后由 salt 于 2014-12-25 15:37 编辑

dsmch老师,请看附件,麻烦dsmch老师看看能否实现不,谢谢dsmch老师。同时提取文件夹里工作薄和仓库出库结算汇总表里的数据,自动在合计后面填充出库数量、单价,然后用出库数量减去合计后的值乘单价,填写金额。非常感谢dsmch老师的奉献。
最佳答案
2014-12-25 15:19
………………

求助.zip

169.9 KB, 下载次数: 8

同时提取文件夹里工作薄和仓库出库结算汇总表里的数据,自动在合计后面填充出库数量、单价,然后用出库数量 ...

 楼主| 发表于 2014-12-25 14:28 | 显示全部楼层
老师,重新上传了,重新模拟了,非常感谢老师,辛苦了。

求助.zip

179.69 KB, 下载次数: 8

回复

使用道具 举报

发表于 2014-12-25 15:16 | 显示全部楼层
  1. Dim w(1 To 10000), s%
  2. Sub Macro1()
  3. Dim arr, brr, crr, d, wb As Workbook, i&, j&, k%
  4. Set d = CreateObject("scripting.dictionary")
  5. arr = ActiveSheet.UsedRange
  6. s = 0
  7. zdir ThisWorkbook.Path & "\2013年腾冲2标段竣工资料"
  8. ReDim brr(1 To UBound(arr) - 2, 1 To s + 5)
  9. Application.ScreenUpdating = False
  10. brr(1, s + 1) = "合计"
  11. brr(1, s + 2) = "出库数量"
  12. brr(1, s + 3) = "单价"
  13. brr(1, s + 4) = "出库-合计"
  14. brr(1, s + 5) = "金额"
  15. For i = 1 To s
  16.     Set wb = GetObject(w(i))
  17.     crr = wb.Sheets("单项工程材料").UsedRange
  18.     wb.Close 0
  19.     x = Split(w(i), "")
  20.     brr(1, i) = Replace(x(UBound(x)), ".xls*", "")
  21.     For j = 4 To UBound(crr)
  22.             brr(j - 2, i) = crr(j, 10)
  23.             brr(j - 2, s + 1) = brr(j - 2, s + 1) + crr(j, 10)
  24.     Next
  25. Next
  26. Set wb = GetObject(ThisWorkbook.Path & "\仓库出库结算汇总.xls")
  27. crr = wb.Sheets(1).Range("a1").CurrentRegion
  28. For i = 6 To UBound(crr)
  29.     zf = crr(i, 2) & "," & crr(i, 3) & "," & crr(i, 4)
  30.     d(zf) = i
  31. Next
  32. For i = 4 To UBound(arr)
  33.     zf = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
  34.     If d.Exists(zf) Then
  35.         n = d(zf)
  36.         brr(i - 2, s + 2) = crr(n, 5)
  37.         brr(i - 2, s + 3) = crr(n, 6)
  38.         brr(i - 2, s + 4) = brr(i - 2, s + 2) - brr(i - 2, s + 1)
  39.         brr(i - 2, s + 5) = brr(i - 2, s + 4) * brr(i - 2, s + 3)
  40.     End If
  41. Next
  42. Range("e3").Resize(UBound(brr), UBound(brr, 2)) = brr
  43. Application.ScreenUpdating = True
  44. End Sub
  45. Sub zdir(p)
  46. Dim fs As New FileSystemObject
  47. For Each f In fs.GetFolder(p).Files
  48.     If f Like "*.xls*" Then s = s + 1: w(s) = f
  49. Next
  50. For Each m In fs.GetFolder(p).SubFolders
  51.     zdir m
  52. Next
  53. End Sub
复制代码
回复

使用道具 举报

发表于 2014-12-25 15:19 | 显示全部楼层    本楼为最佳答案   
………………

求助.zip

164.57 KB, 下载次数: 34

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 20:35 , Processed in 0.619981 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表