Excel精英培训网

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

[已解决]求助:提取多文件夹下工作表中的内容

[复制链接]
发表于 2014-6-4 14:49 | 显示全部楼层 |阅读模式
本帖最后由 天龙九部 于 2014-6-5 08:53 编辑

工作表格式固定,把工作表内容提取到"汇总表"中,要求已在"汇总表"中说明
最佳答案
2014-6-4 20:24
………………

付款单.rar

22.98 KB, 下载次数: 14

发表于 2014-6-4 16:39 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2014-6-4 16:46 | 显示全部楼层
qh8600 发表于 2014-6-4 16:39
知道要汇总,为什么弄这么多表格

别人发来的表
回复

使用道具 举报

发表于 2014-6-4 16:53 | 显示全部楼层
天龙九部 发表于 2014-6-4 16:46
别人发来的表

估计是不行,要遍历10000多工作簿,好几万个工作表,会死机的
回复

使用道具 举报

 楼主| 发表于 2014-6-4 17:01 | 显示全部楼层
qh8600 发表于 2014-6-4 16:53
估计是不行,要遍历10000多工作簿,好几万个工作表,会死机的

万一不行,就帮看看同一文件下,能行下?
回复

使用道具 举报

发表于 2014-6-4 17:09 | 显示全部楼层
天龙九部 发表于 2014-6-4 17:01
万一不行,就帮看看同一文件下,能行下?

这不是同不同一文件夹没有关系的,主要是你表格太多了,会死机的,另外一个数值写一个单元格,也不是一种好的做法,要等高手出现,不知有没有办法
回复

使用道具 举报

发表于 2014-6-4 20:22 | 显示全部楼层
  1. Dim arr(), s&
  2. Sub Macro1()
  3. s = 0
  4. ReDim arr(1 To 20000, 1 To 7)
  5. zdir ThisWorkbook.Path & ""
  6. Range("a2").Resize(s, 7) = arr
  7. End Sub
  8. Sub zdir(p)
  9. Dim fs As Object, wb As Workbook
  10. Set fs = CreateObject("scripting.filesystemobject")
  11. Application.ScreenUpdating = False
  12. For Each f In fs.GetFolder(p).Files
  13.     x = Split(f, "")
  14.     If x(UBound(x)) <> ThisWorkbook.Name Then
  15.         zf1 = x(UBound(x) - 1)
  16.         zf2 = Replace(x(UBound(x)), ".xls", "")
  17.         Set wb = GetObject(f)
  18.         For i = 1 To wb.Sheets.Count
  19.             zf3 = wb.Sheets(i).Name
  20.             brr = wb.Sheets(i).[a1:s9]
  21.             With CreateObject("vbscript.regexp")
  22.                 .Pattern = "\D"
  23.                 .Global = True
  24.                 d = .Replace(brr(2, 1), "")
  25.             End With
  26.             For j = 5 To 9
  27.                 If Not brr(j, 1) Like "*以下空白*" And brr(j, 1) <> "" And Not brr(j, 1) Like "*款付清*" Then
  28.                     s = s + 1
  29.                     arr(s, 1) = zf1
  30.                     arr(s, 2) = zf2
  31.                     arr(s, 3) = zf3
  32.                     arr(s, 4) = DateSerial(Left(d, 4), Mid(d, 5, 2), Right(d, 2))
  33.                     arr(s, 5) = brr(j, 1)
  34.                     arr(s, 6) = Replace(Join(Application.Index(brr, j, 0), ""), brr(j, 1), "") / 100
  35.                 End If
  36.                 If brr(j, 1) Like "*款付清*" Then arr(s, 7) = "款付清"
  37.             Next
  38.         Next
  39.         wb.Close 0
  40.     End If
  41. Next
  42. For Each m In fs.GetFolder(p).SubFolders
  43.     zdir m
  44. Next
  45. Application.ScreenUpdating = True
  46. End Sub
复制代码
回复

使用道具 举报

发表于 2014-6-4 20:24 | 显示全部楼层    本楼为最佳答案   
………………

付款单.zip

33.68 KB, 下载次数: 34

回复

使用道具 举报

 楼主| 发表于 2014-6-5 08:51 | 显示全部楼层
dsmch 发表于 2014-6-4 20:22

感谢帮助
回复

使用道具 举报

发表于 2014-6-5 14:09 | 显示全部楼层
学习
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 22:28 , Processed in 0.487677 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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