合并工具-Excel VBA程序开发-ExcelHome技术论坛

3190496160 Lv.7

2022-9-16 11:04 关注

两个功能：

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

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

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

合并工具.rar 2022-9-16 11:04 上传

136.77 KB, 下载次数: 654

赏

有 12 人给楼主打赏

5976阅读

3190496160 楼主 置顶来自 15楼

2022-9-21 17:37

多薄多表合并中，增加了在A列写入原文件名称功能，

合并工具.rar 2022-9-21 17:37 上传

138.17 KB, 下载次数: 316

3190496160 楼主 置顶来自 26楼

2022-11-20 21:42

1、增加了一个功能：多薄一表合并为一薄一表功能
2、解决了合并多薄多表为一薄多表时出错的问题，
欢迎下载使用，发现问题希望积极反馈

合并工具.rar 2022-11-20 21:42 上传

40.8 KB, 下载次数: 131

3190496160 楼主 置顶来自 27楼

2022-11-23 20:26

合并工具.rar 2022-11-23 20:25 上传

35.08 KB, 下载次数: 126

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

3190496160 楼主 置顶来自 33楼

2022-12-7 11:38

修正了两个小问题，需要请在此楼下载

合并工具.rar 2022-12-7 11:38 上传

47.88 KB, 下载次数: 404

3190496160 楼主 2楼

2022-9-16 11:05

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 楼主 3楼

2022-9-16 11:06

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