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

 本帖最后由 百度不到去谷歌 于 2017-3-13 18:50 编辑

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

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:\\"
    
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. 
    
80. Sub 合并()
    
81.     files = FileList(ThisWorkbook.sheets("参数").[B3].Value, "*.xls*")
    
82.     合并数据 files
    
83. End Sub

复制代码

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