|
|
本帖最后由 百度不到去谷歌 于 2017-3-13 18:50 编辑
各处的论坛和qq群大量的人求助如何合并excel文件,我原来也写过几个版本 这次编写了这个完全免费并开源的合并工具,本工具可对各种EXCEL文件进行数据合并,只要表格结构一致,可选择文件中合并的sheet表名,可选择是否保留源数据格式,更多便利请自行下载体会,附带视频讲解及案例说明
视频讲解使用说明http://excel880.com/blog/archives/1514
- Private Sub 合并数据(files)
- Application.Calculation = xlManual
- Application.ScreenUpdating = False
- ProgressBarStart '进度条初始化
- Dim wbk As Workbook, sht As Worksheet, i&, arr, targetsht As Worksheet
- Dim iRow As Long, cn As Long, targeWbk As Workbook
- Set targeWbk = Workbooks.Add
- targeWbk.sheets(1).Name = "合并"
- Set targetsht = targeWbk.sheets(1)
- iRow = ThisWorkbook.sheets("参数").[B4] '数据起始行
- Dim k, mysheets As Collection
- For i = 1 To UBound(files)
- Set wbk = Workbooks.Open(files(i)) '源数据
- k = 0
- Set mysheets = 子表选择(wbk, ThisWorkbook.sheets("参数").[B5])
- If i = 1 And iRow > 1 Then '写入目标表头
- mysheets(1).Range("A1").Resize(iRow - 1, 256).Copy targetsht.Range("A1").Resize(iRow - 1, 256)
- End If
- For k = 1 To mysheets.Count
- ProgressUpdate (i - 1) / UBound(files) + k / mysheets.Count, "正在合并 " & wbk.Name & "!" & mysheets(k).Name
- 单表合并 mysheets(k), targetsht, ThisWorkbook.sheets("参数").[B6], ThisWorkbook.sheets("参数").[B7]
- Next
- wbk.Close False
- Next
- targeWbk.sheets(1).Columns.AutoFit
- ProgressUpdate 1, "合并完成!"
- MsgBox "合并已完成!欢迎访问EXCEL880.COM 学习获取更多EXCEL技术"
- Shell "explorer http:\\excel880.com"
-
- targeWbk.SaveAs ThisWorkbook.Path & "" & Format(Now, "yymmdd-hhmm ") & "合并.xlsx"
-
- Application.Calculation = xlAutomatic
- Application.ScreenUpdating = True
- End Sub
- Private Function 子表选择(tagetwbk, 表名) As Collection '通过表名参数确定目标工作簿要合并的sheet列表
- ' 默认为空 --合并所有sheet
- '填1表示合并每个表的激活表,
- '填具体表名以*分隔 如 sheet2*sheet3 则合并源表中表名对应的sheet2,sheet3
- '用*分隔是因为表名是不可能带有*的 不会冲突
- Dim shts As New Collection, s, sht, x
- If 表名 = 1 Then
- shts.Add tagetwbk.ActiveSheet '取每个表的活动工作表
- ElseIf 表名 = "" Then
- For Each sht In tagetwbk.Worksheets
- shts.Add sht
- Next
- Else
- s = "*" & 表名 & "*" '预设工作表名以*分隔
- For Each sht In tagetwbk.Worksheets
- If InStr(s, "*" & sht.Name & "*") > 0 Then
- shts.Add sht
- End If
- Next
- End If
- Set 子表选择 = shts
- End Function
- Private Sub 单表合并(源表 As Worksheet, 目标 As Worksheet, 合并方式, 是否备注) '带格式(慢),无格式(快)
- Dim arr, cn, rn, iRow, targetRow
- iRow = ThisWorkbook.sheets("参数").[B4]
- cn = 源表.Cells.Find("*", 源表.Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column '计算一个工作表的非空列号
- rn = E8_UsedRange(源表).Rows.Count
- arr = 源表.Cells(iRow, 1).Resize(rn, cn)
- If E8_UsedRange(目标) Is Nothing Then '可能目标表为空
- targetRow = 1
- Else
- targetRow = E8_UsedRange(目标).Rows.Count + 1
- End If
-
- If 合并方式 = "无格式(快)" Then '数组写入
- 目标.Cells(targetRow, 1).Resize(rn, cn) = arr
- Else '复制range
- 源表.Cells(iRow, 1).Resize(rn, cn).Copy 目标.Cells(targetRow, 1).Resize(rn, cn)
- End If
- If 是否备注 = "是" Then
- 目标.Cells(targetRow, cn + 1).Resize(rn) = 源表.Parent.Name & "!" & 源表.Name
- End If
-
- End Sub
- Sub 合并()
- files = FileList(ThisWorkbook.sheets("参数").[B3].Value, "*.xls*")
- 合并数据 files
- End Sub
工具文件下载地址
EXCEL880多文件多表合并工具 2.1.rar
(809.18 KB, 下载次数: 1517)
|
评分
-
7
查看全部评分
-
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2017-3-12 20:41
发表于 2017-3-12 21:11
楼主
