参考：
VBA 合并同文件夹下多工作簿中同名工作表到 一工作簿一工作表
/1/19 更新
跳过不含指定sheet的工作薄并汇总。
Sub Build_Sheet_List()Dim sht As Worksheet, i As Long, strName As StringWith Columns(1).Clear '清空A列数据.NumberFormat = "@" '设置文本格式End WithFor i = 1 To Sheets.Count '索引法遍历工作表集合strName = Sheets(i).Name '表名Cells(i, 1).Value = strNameActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _SubAddress:="'" & strName & "'!a1", TextToDisplay:=strNameNextEnd SubSub all_excel_files()Dim path As String, filename As StringDim w As Workbook, ws As WorkbookWith Application.FileDialog(msoFileDialogFolderPicker)'-------------------取得用户选择的文件夹路径---------------------------If .Show Then path = .SelectedItems(1) Else Exit SubEnd WithIf Right(path, 1) <> "\" Then path = path & "\"filename = Dir(path & "\*.xls*")Application.DisplayAlerts = False'-------------------取得用户选择的合并工作表名---------------------------strKey = InputBox("请输入需要合并的工作表名：", "提醒")If StrPtr(strKey) = 0 Then Exit Sub'-----------打开指定文件夹下的工作薄，复制粘贴工作表到汇总表，重命名--------------------Set ws = Workbooks.AddDo While filename <> ""'w代表指定文件夹下每个找到的excel文件Set w = Workbooks.Open(path & "\" & filename)'选择工作表，复制，并粘贴为汇总表的最后一张If strKey = ActiveSheet.Name Thenw.Sheets(strKey).Copy after:=ws.Sheets(ws.Sheets.Count)' 重命名刚贴的表名为excel文件名If Right(filename, 4) = "xls*" Then ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 4) Else ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 5)End If' 关闭工作簿w.Close'下一个filename = DirLoop'-----------制作目录工作表--------------------Sheets("Sheet1").Name = "目录"Sheets("目录").SelectCall Build_Sheet_ListApplication.DisplayAlerts = Truews.SaveAs path & "\汇总.xlsx"End Sub
将所汇总的数据逐个添加到同一工作表中见下载链接：
/download/weixin_42750611/76744062
效果如下：
/8/10
在原先代码的基础上修改，可以自由选择和输入要合并多工作簿的同文件夹和工作表名，并生成目录页。
效果展示：
1、选择工作表
2、输入指定相同工作表名
3、等待程序执行完毕。
代码如下：
Sub Build_Sheet_List()Dim sht As Worksheet, i As Long, strName As StringWith Columns(1).Clear '清空A列数据.NumberFormat = "@" '设置文本格式End WithFor i = 1 To Sheets.Count '索引法遍历工作表集合strName = Sheets(i).Name '表名Cells(i, 1).Value = strNameActiveSheet.Hyperlinks.Add anchor:=Cells(i, 1), Address:="", _SubAddress:="'" & strName & "'!a1", TextToDisplay:=strNameNextEnd SubSub all_excel_files()Dim path As String, filename As StringDim w As Workbook, ws As WorkbookWith Application.FileDialog(msoFileDialogFolderPicker)'-------------------取得用户选择的文件夹路径---------------------------If .Show Then path = .SelectedItems(1) Else Exit SubEnd WithIf Right(path, 1) <> "\" Then path = path & "\"filename = Dir(path & "\*.xls")Application.DisplayAlerts = False'-------------------取得用户选择的合并工作表名---------------------------strKey = InputBox("请输入需要合并的工作表名：", "提醒")If StrPtr(strKey) = 0 Then Exit Sub'-----------打开指定文件夹下的工作薄，复制粘贴工作表到汇总表，重命名--------------------Set ws = Workbooks.AddDo While filename <> ""'w代表指定文件夹下每个找到的excel文件Set w = Workbooks.Open(path & "\" & filename)'选择工作表，复制，并粘贴为汇总表的最后一张If strKey <> ActiveSheet.Name Then w.CloseIf strKey <> ActiveSheet.Name Then MsgBox "该文件夹内存在不含指定工作表名的工作薄，请重新检查！", 64, "提示": Exit Subw.Sheets(strKey).Copy after:=ws.Sheets(ws.Sheets.Count)'重命名刚贴的表名为excel文件名If Right(filename, 4) = ".xls" Then ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 4) Else ws.Worksheets(ws.Sheets.Count).Name = Mid(filename, 1, Len(filename) - 5)'关闭工作簿w.Close'下一个filename = DirLoop'-----------制作目录工作表--------------------Sheets("Sheet1").Name = "目录"Sheets("目录").SelectCall Build_Sheet_ListApplication.DisplayAlerts = Truews.SaveAs path & "\汇总.xlsx"End Sub
小提示：
1、如果只想打开文件夹内的xlsx文件filename = Dir(path & "\*.xls")改为filename = Dir(path & "\*.xlsx*")可以同时打开文件夹中的xls文件。
