ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

免费EXCEL 多文件多表格合并工具 附视频讲解使用说明 VBA代码开源

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2017-3-12 20:41 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:工作表和工作簿
本帖最后由 百度不到去谷歌 于 2017-3-13 18:50 编辑

各处的论坛和qq群大量的人求助如何合并excel文件,我原来也写过几个版本 这次编写了这个完全免费并开源的合并工具,本工具可对各种EXCEL文件进行数据合并,只要表格结构一致,可选择文件中合并的sheet表名,可选择是否保留源数据格式,更多便利请自行下载体会,附带视频讲解及案例说明
视频讲解使用说明http://excel880.com/blog/archives/1514
QQ截图20170312163751.png

  1. Private Sub 合并数据(files)
  2.     Application.Calculation = xlManual
  3.     Application.ScreenUpdating = False
  4.     ProgressBarStart '进度条初始化
  5.     Dim wbk As Workbook, sht As Worksheet, i&, arr, targetsht As Worksheet
  6.     Dim iRow As Long, cn As Long, targeWbk As Workbook
  7.     Set targeWbk = Workbooks.Add
  8.     targeWbk.sheets(1).Name = "合并"
  9.     Set targetsht = targeWbk.sheets(1)
  10.     iRow = ThisWorkbook.sheets("参数").[B4]    '数据起始行
  11.     Dim k, mysheets As Collection
  12.     For i = 1 To UBound(files)
  13.         Set wbk = Workbooks.Open(files(i))    '源数据
  14.         k = 0
  15.         Set mysheets = 子表选择(wbk, ThisWorkbook.sheets("参数").[B5])
  16.         If i = 1 And iRow > 1 Then    '写入目标表头
  17.             mysheets(1).Range("A1").Resize(iRow - 1, 256).Copy targetsht.Range("A1").Resize(iRow - 1, 256)
  18.         End If
  19.         For k = 1 To mysheets.Count
  20.             ProgressUpdate (i - 1) / UBound(files) + k / mysheets.Count, "正在合并 " & wbk.Name & "!" & mysheets(k).Name
  21.             单表合并 mysheets(k), targetsht, ThisWorkbook.sheets("参数").[B6], ThisWorkbook.sheets("参数").[B7]
  22.         Next
  23.         wbk.Close False
  24.     Next
  25.     targeWbk.sheets(1).Columns.AutoFit
  26.     ProgressUpdate 1, "合并完成!"
  27.     MsgBox "合并已完成!欢迎访问EXCEL880.COM 学习获取更多EXCEL技术"
  28.     Shell "explorer http:\\excel880.com"
  29.    
  30.     targeWbk.SaveAs ThisWorkbook.Path & "" & Format(Now, "yymmdd-hhmm ") & "合并.xlsx"
  31.    
  32.     Application.Calculation = xlAutomatic
  33.     Application.ScreenUpdating = True
  34. End Sub
  35. Private Function 子表选择(tagetwbk, 表名) As Collection '通过表名参数确定目标工作簿要合并的sheet列表
  36.    ' 默认为空 --合并所有sheet
  37.     '填1表示合并每个表的激活表,
  38.     '填具体表名以*分隔 如  sheet2*sheet3 则合并源表中表名对应的sheet2,sheet3
  39.     '用*分隔是因为表名是不可能带有*的 不会冲突
  40.     Dim shts As New Collection, s, sht, x
  41.     If 表名 = 1 Then
  42.         shts.Add tagetwbk.ActiveSheet '取每个表的活动工作表
  43.     ElseIf 表名 = "" Then
  44.         For Each sht In tagetwbk.Worksheets
  45.             shts.Add sht
  46.         Next
  47.     Else
  48.         s = "*" & 表名 & "*" '预设工作表名以*分隔
  49.         For Each sht In tagetwbk.Worksheets
  50.             If InStr(s, "*" & sht.Name & "*") > 0 Then
  51.                 shts.Add sht
  52.             End If
  53.         Next
  54.     End If
  55.     Set 子表选择 = shts
  56. End Function
  57. Private Sub 单表合并(源表 As Worksheet, 目标 As Worksheet, 合并方式, 是否备注) '带格式(慢),无格式(快)
  58.     Dim arr, cn, rn, iRow, targetRow
  59.     iRow = ThisWorkbook.sheets("参数").[B4]
  60.     cn = 源表.Cells.Find("*", 源表.Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column    '计算一个工作表的非空列号
  61.     rn = E8_UsedRange(源表).Rows.Count
  62.     arr = 源表.Cells(iRow, 1).Resize(rn, cn)
  63.     If E8_UsedRange(目标) Is Nothing Then    '可能目标表为空
  64.         targetRow = 1
  65.     Else
  66.         targetRow = E8_UsedRange(目标).Rows.Count + 1
  67.     End If
  68.    
  69.     If 合并方式 = "无格式(快)" Then '数组写入
  70.         目标.Cells(targetRow, 1).Resize(rn, cn) = arr
  71.     Else    '复制range
  72.         源表.Cells(iRow, 1).Resize(rn, cn).Copy 目标.Cells(targetRow, 1).Resize(rn, cn)
  73.     End If
  74.     If 是否备注 = "是" Then
  75.         目标.Cells(targetRow, cn + 1).Resize(rn) = 源表.Parent.Name & "!" & 源表.Name
  76.     End If
  77.    
  78. End Sub

  79. Sub 合并()
  80.     files = FileList(ThisWorkbook.sheets("参数").[B3].Value, "*.xls*")
  81.     合并数据 files
  82. End Sub
复制代码

工具文件下载地址
EXCEL880多文件多表合并工具 2.1.rar (809.18 KB, 下载次数: 1486)



评分

7

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-3-12 21:11 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-3-12 21:37 | 显示全部楼层
本帖最后由 jjmysjg 于 2017-3-12 21:39 编辑

谢谢大师,收下了
数据多的,变成了科学显示,能修改吗

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-3-12 21:52 | 显示全部楼层
jjmysjg 发表于 2017-3-12 21:37
谢谢大师,收下了
数据多的,变成了科学显示,能修改吗

合并完了设置格式就行了 或者用某一个分表打开 复制列宽粘贴到合并结果表列宽

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-3-13 22:28 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
更新2.1版本 原版首行如果列数与表头列数不一致会出错 有人问到固定列数如何设置 直接在代码里改变量 cn=列号 即可

TA的精华主题

TA的得分主题

发表于 2017-3-14 12:37 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-3-30 11:59 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-4-9 23:09 | 显示全部楼层
多文件多表格合并工具和易用宝里的合并是不是一样的功能?

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-4-10 08:18 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
qmm5833 发表于 2017-4-9 23:09
多文件多表格合并工具和易用宝里的合并是不是一样的功能?

灵活性更高一点  自行体会

TA的精华主题

TA的得分主题

发表于 2017-4-10 08:55 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 15:02 , Processed in 0.047756 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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