合并工具

3190496160

两个功能：

1、合并多薄一表为一薄多表
2、合并多薄多表为一薄多表
简述：

一、合并多薄一表为一薄多表：
1、适合合并一个文件夹内的多个工作簿到一个工作簿内，
2、默认合并文件夹下的每个工作簿的第一个工作表
3、合并后的工作表名称用原工作薄名称命名
4、合并后自动建立目录并自动建立超链接

二、合并多薄多表为一薄多表：
1、适合合并一个文件夹下的多个工作簿到一个工作簿内
2、文件夹下的每个工作簿有多个工作表，并且，所有工作簿的工作表名称是一致的
3、合并后，把每个工作簿内相同名称的工作表内的数据合并到一个工作表内。
4、合并后自动建立目录并自动建立超链接
欢迎提出意见和建议，不喜勿喷
合并工具.rar (136.77 KB, 下载次数: 741)

2022-9-16 11:04 上传

点击文件名下载附件

3190496160

多薄多表合并中，增加了在A列写入原文件名称功能，
合并工具.rar (138.17 KB, 下载次数: 379)

2022-9-21 17:37 上传

点击文件名下载附件

3190496160

1、增加了一个功能：多薄一表合并为一薄一表功能
2、解决了合并多薄多表为一薄多表时出错的问题，
欢迎下载使用，发现问题希望积极反馈
合并工具.rar (40.8 KB, 下载次数: 168)

2022-11-20 21:42 上传

点击文件名下载附件

3190496160

合并工具.rar (35.08 KB, 下载次数: 172)

2022-11-23 20:25 上传

点击文件名下载附件

增加了一个功能：一薄多表合并为一个工作表

3190496160

修正了两个小问题，需要请在此楼下载
合并工具.rar (47.88 KB, 下载次数: 571)

2022-12-7 11:38 上传

点击文件名下载附件

3190496160

Sub 合并多薄一表为一薄多表()
Application.ScreenUpdating = False
Dim ww As Workbook
Dim sh As Worksheet
Dim arr(), brr()
Dim wb As Workbook
Dim dlgOpen As FileDialog
Set ww = ThisWorkbook
Set sht = ww.Worksheets("目录")
sht.[a1].CurrentRegion.Offset(1) = Empty
lj = ThisWorkbook.Path
VBA.ChDir lj
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
    If .Show <> -1 Then MsgBox "您没有选择文件夹！": Exit Sub
    lj = .SelectedItems(1)
End With
Application.DisplayAlerts = False
For Each sh In ww.Worksheets
    If sh.Index > 1 Then sh.Delete
Next sh
Application.DisplayAlerts = True
t = Timer
f = Dir(lj & "\*.xls*")
m = 1
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        m = m + 1
        Set wb = Workbooks.Open(lj & "\" & f, 0)
        wb.Worksheets(1).Copy after:=ww.Worksheets(ww.Worksheets.Count)
        mc = Split(wb.Name, ".")(0)
        With ww.Worksheets(ww.Worksheets.Count)
            .Name = mc
        End With
        sht.Cells(m, 1) = m - 1
        sht.Cells(m, 2) = mc
        sht.Hyperlinks.Add anchor:=sht.Cells(m, 2), Address:="", SubAddress:="'" & mc & "'!a1", TextToDisplay:=mc
       wb.Close False
    End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "合并完毕！耗时：" & Format(Timer - t, "0.00") & "秒", 64, "EXCEL提醒"
End Sub

3190496160

Sub 合并多薄多表为一薄多表()
Application.ScreenUpdating = False
Dim ww As Workbook
Dim sh As Worksheet
Dim arr(), brr()
Dim wb As Workbook
Dim dlgOpen As FileDialog
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set ww = ThisWorkbook
Set sht = ww.Worksheets("目录")
sht.[a1].CurrentRegion.Offset(1) = Empty
lj = ThisWorkbook.Path
VBA.ChDir lj
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
    If .Show <> -1 Then MsgBox "您没有选择文件夹！": Exit Sub
    lj = .SelectedItems(1)
End With
Application.DisplayAlerts = False
For Each sh In ww.Worksheets
    If sh.Index > 1 Then sh.Delete
Next sh
Application.DisplayAlerts = True
t = Timer
f = Dir(lj & "\*.xls*")
m = 1
bt = InputBox("请输入待合并工作表的标题行数", "标题行数", "2")
If bt = "" Then MsgBox "您没有输入标题行数，请按确定退出！": Exit Sub
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(lj & "\" & f, 0)
        For Each sh In wb.Worksheets
            r = sh.UsedRange.Rows.Count
            If r > Val(bt) Then
                If Not d.exists(sh.Name) Then
                    sh.Copy after:=ww.Worksheets(ww.Worksheets.Count)
                    d(sh.Name) = ""
                    m = m + 1
                    sht.Cells(m, 1) = m - 1
                    sht.Cells(m, 2) = mc
                    sht.Hyperlinks.Add anchor:=sht.Cells(m, 2), Address:="", SubAddress:="'" & sh.Name & "'!a1", TextToDisplay:=sh.Name
                Else
                    rs = ww.Worksheets(sh.Name).UsedRange.Rows.Count + 1
                    sh.Rows(Val(bt) + 1 & ":" & r).Copy ww.Worksheets(sh.Name).Cells(rs, 1)
                End If
            End If
        Next sh
       wb.Close False
    End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "合并完毕！耗时：" & Format(Timer - t, "0.00") & "秒", 64, "EXCEL提醒"
End Sub

aecn

通用性强，感谢分享

乐轻入梦

非常好的多簿合一的示例，非常强大，我回去试一下

blackttea1

好程序，谢谢

zylz9941

谢谢分享！！！

zylz9941

3190496160 发表于 2022-9-16 11:06
Sub 合并多薄多表为一薄多表()
Application.ScreenUpdating = False
Dim ww As Workbook

麻烦楼主测试一下，好像含图片的工资表合并后无图片

qqyyh

太好了，谢谢大神！！

qlmgu

谢谢分享下载了