ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 6952|回复: 15

[求助] 如何将多个不同名称的文件夹中的相同名称的工作簿进行合并,形成新的工作簿。

[复制链接]

TA的精华主题

TA的得分主题

发表于 2014-12-10 15:16 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 112ppp 于 2014-12-10 15:19 编辑

现有无数个文件夹,每个文件夹中有无数个名称相同的工作簿,如下图例举的“期”和“拼”两个文件夹,文件夹中都有三个相同名字的工作簿:复、特、新。(有可能文件夹还会有几个不同名称的工作簿)


现需要将这些文件夹中存在相同名称的工作簿中的表格进行合并,形成新的工作簿,工作簿名称不变。如图所示。(不相同名称的工作簿直接引入“需要得到的结果”的文件夹中。)


新合并后的每个工作簿中就存在了多个工作表,工作表名称均需按来源的文件夹名称来进行重命名。如

说明:新合并后的工作簿中的表格是来源于几个文件夹,则就有几个工作表。如果来源于二个文件夹,就有二个工作表,总之来源于几个文件夹新合并后的工作簿中就有几个工作表。如果仅来源于一个文件夹,工作簿中就只有一个工作表,但表中名称仍然需要更改成来源文件夹的名称。

请各位老师帮助编写个VBA,拜托了。

合并表格.rar

54.83 KB, 下载次数: 97

TA的精华主题

TA的得分主题

发表于 2014-12-11 10:00 | 显示全部楼层
本帖最后由 opiona 于 2014-12-11 10:34 编辑

自定义函数见附件: 合并表格.rar (79.13 KB, 下载次数: 347)
不知道是否符合要求


  1. '*********************************
  2. '*******  北极狐工作室出品  ******
  3. '*******  QQ:14885553      ******
  4. '*********************************

  5. Sub Opiona()

  6. 'On Error Resume Next    '// 发生错误,自动执行下一句,就是忽略错误
  7. Application.ScreenUpdating = False '//关闭屏幕刷新
  8. Application.DisplayAlerts = False '//关闭系统提示

  9. Path = ThisWorkbook.Path & "\数据"
  10. FileArr = FileAllArr(Path, "*.xlsx", ThisWorkbook.Name, False)
  11. Filename = ""
  12. For I = 0 To UBound(FileArr)
  13.     If InStr(Filename, GetPathFromFileName(FileArr(I))) = 0 Then
  14.        Filename = Filename & GetPathFromFileName(FileArr(I)) & ";"
  15.     End If
  16. Next
  17. FileNameArr = Split(Mid(Filename, 1, Len(Filename) - 1), ";")  '//不重复工作簿名称列表
  18. DirArr = FileAllArr(Path, "*.xlsx", ThisWorkbook.Name, True)
  19. For I = 0 To 0 'UBound(FileNameArr)
  20.     Set NwBook = Workbooks.Add   '新建一个工作簿
  21.     For K = 0 To UBound(DirArr)  '//加入工作表,用文件夹命名
  22.          NewName = Replace(Replace(DirArr(K), ThisWorkbook.Path & "\数据", ""), "", "")
  23.          NwBook.Worksheets.Add().Name = NewName
  24.          Set Sh = NwBook.Sheets(NewName)
  25.             Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & DirArr(K) & FileNameArr(I) & ".xlsx"
  26.             StrSQL = "SELECT * FROM [" & FileNameArr(I) & "$]"
  27.             CRR = GET_SQLCoon(StrSQL, Str_coon, True)
  28.             Sh.Range("A1").Resize(UBound(CRR, 1) + 1, UBound(CRR, 2) + 1) = CRR
  29.     Next K
  30.     NwBook.SaveAs ThisWorkbook.Path & "\需要得到的结果" & FileNameArr(I) & ".xlsx"    '另存为指定目录的指定文件名
  31.     NwBook.Close (True)  '关闭(保存)
  32. Next I

  33. Application.ScreenUpdating = True '//恢复屏幕刷新
  34. Application.DisplayAlerts = True '//恢复系统提示
  35. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-12-22 17:20 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
opiona 发表于 2014-12-11 10:00
自定义函数见附件:
不知道是否符合要求

好像不行哦,只汇总了一个表。

TA的精华主题

TA的得分主题

发表于 2014-12-22 19:10 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
还有问题,合并了 复.xlsx,其他的没合并。

TA的精华主题

TA的得分主题

发表于 2014-12-25 08:44 | 显示全部楼层
For I = 0 To 0 'UBound(FileNameArr)
修改成:
  1. For I = 0 To UBound(FileNameArr)
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-1-21 13:54 | 显示全部楼层
opiona 发表于 2014-12-25 08:44
For I = 0 To 0 'UBound(FileNameArr)
修改成:

感谢 ,成功了,是我要的结果。

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-1-21 14:36 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 112ppp 于 2015-1-21 14:41 编辑
opiona 发表于 2014-12-25 08:44
For I = 0 To 0 'UBound(FileNameArr)
修改成:

这段代码是什么意思?为什么我放新的文件夹到数据文件夹里,就汇总不了了呢,这一句就反黄色的了。提示需要调试。

TA的精华主题

TA的得分主题

发表于 2015-1-29 08:56 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-5-31 15:36 | 显示全部楼层
本帖最后由 vince鑫15 于 2016-5-31 15:39 编辑

opiona  老师:
你好 我和楼主有差不多的要求, 但是我运行您的程序时似乎无法执行 (因为我对VBA不太了解,所以我就是下载下来后按照楼主的格式设置了一下文件夹。然后run )  不知道问题在哪里?麻烦您帮我看一下  (我需要合并的工作簿有上百个)``

汇总.rar

692.21 KB, 下载次数: 49

TA的精华主题

TA的得分主题

发表于 2016-5-31 15:49 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

老师您好,求助~~具体看9楼  
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 07:20 , Processed in 0.048375 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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