Excel精英培训网

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

[已解决]汇总 多个文件夹里多个工作表汇总

[复制链接]
发表于 2015-1-23 15:07 | 显示全部楼层 |阅读模式
本帖最后由 wxfwxj 于 2015-1-23 15:09 编辑

2014年.zip (326.55 KB, 下载次数: 3)
发表于 2015-1-23 16:05 | 显示全部楼层
  1. Sub 汇总()
  2.     Application.ScreenUpdating = False
  3.     Dim Wb As Workbook, Sh As Worksheet
  4.     Set fso = CreateObject("scripting.filesystemobject")
  5.     Set d = CreateObject("scripting.dictionary")
  6.     Set ff = fso.getfolder(ThisWorkbook.Path)        '当前文件夹
  7.     Dim brr(1 To 10000, 1 To 6)
  8.     For Each fff In ff.subfolders        '所有子文件夹
  9.        For Each f In fff.Files        '子文件夹中的所有文件
  10.          yf = Val(Mid(Replace(f, fff, ""), 2)) & "月份"        '根据文件名截取月份
  11.          Set Wb = Workbooks.Open(f)
  12.          Set Sh = Wb.Worksheets("产量")
  13.          arr = Sh.Range("a1:n" & Sh.[d65536].End(3).Row)
  14.          For i = 11 To UBound(arr)
  15.             If arr(i, 2) Like "*组" Then zu = Trim(arr(i, 2))
  16.             If arr(i, 4) = "标段" Then Exit For
  17.             If arr(i, 4) <> "" Then       '把所有内容存入数组Brr,并按地名分组
  18.                 dm = Left(arr(i, 4), 2) '地名
  19.                 n = n + 1
  20.                 brr(n, 2) = arr(i, 4)   '标段名称
  21.                 brr(n, 3) = arr(i, 6)   '数量
  22.                 brr(n, 4) = arr(i, 9)  '总重量
  23.                 brr(n, 5) = yf    '月份
  24.                 brr(n, 6) = zu    '制作组
  25.                 d(dm) = d(dm) & "," & n      '把行数按地名分组
  26.             End If
  27.         Next
  28.          Wb.Close False
  29.        Next
  30.     Next
  31.    
  32.     dk = d.keys: dt = d.items
  33.     For i = 0 To UBound(dk)
  34.         Sheets("表式").Copy after:=Sheets(Sheets.Count)
  35.         With ActiveSheet
  36.             .Name = dk(i)  '表名
  37.             xrr = Split(dt(i), ",")        '还原按地名分组的各行
  38.             ReDim crr(1 To UBound(xrr), 1 To 6)
  39.             For j = 1 To UBound(xrr)
  40.                 n = Val(xrr(j))
  41.                 crr(j, 1) = j
  42.                 For k = 2 To 6
  43.                     crr(j, k) = brr(n, k)
  44.                 Next
  45.             Next
  46.             .[b5].Resize(j - 1, 6) = crr
  47.         End With
  48.     Next
  49.     Sheets(1).Activate
  50.     Application.ScreenUpdating = True
  51. End Sub

  52. Sub 删除()
  53.     Application.DisplayAlerts = False
  54.     For Each Sh In Worksheets
  55.         If Sh.Index > 2 Then Sh.Delete
  56.     Next
  57.     Application.DisplayAlerts = True
  58. End Sub
复制代码
回复

使用道具 举报

发表于 2015-1-23 16:07 | 显示全部楼层    本楼为最佳答案   
为便于操作,把汇总表放在当前目录下。当前目录内只有各月份的子目录。

2014年.rar

261.51 KB, 下载次数: 29

回复

使用道具 举报

发表于 2015-1-23 16:07 | 显示全部楼层
地名无法智能判断,只能取内容的前两位。
回复

使用道具 举报

 楼主| 发表于 2015-1-24 19:40 | 显示全部楼层
谢谢1973老师
回复

使用道具 举报

 楼主| 发表于 2015-1-25 08:19 | 显示全部楼层
你好1973老师 我在月份文件夹里不只一个工作簿 工作簿多了就出差了
如何解决
回复

使用道具 举报

发表于 2015-1-26 10:01 | 显示全部楼层
加了汇总。你把出差的附件上传一个,要调试一下才知道。

2014年.rar

262.04 KB, 下载次数: 4

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 18:53 , Processed in 0.763067 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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