把多个工作簿合并到一个工作簿作为新工作簿的一张表（宏代码）Sub 合并当前目录下所有工作簿的全部工作表() Dim MyPath, MyName, AWbNameDim Wb As Workbook, WbN As String Dim G As LongDim Num As Long Dim BOX As StringApplication.ScreenUpdating = False MyPath = ActiveWorkbook.Path MyName = Dir(MyPath & & *.xls) AWbName = ActiveWorkbook.Name Num = 0Do While MyName If MyName AWbName ThenSet Wb = Workbooks.Open(MyPath & & MyName) Num = Num + 1With Workbooks(1).ActiveSheet.Cells(.Range(A65536).End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = 1 To Sheets.CountWb.Sheets(G).UsedRange.Copy .Cells(.Range(A65536).End(xlUp).Row + 1, 1) NextWbN = WbN & Chr(13) & Wb.Name Wb.Close FalseEnd With End IfMyName = Dir Loop Range(A1).SelectApplication.ScreenUpdating = TrueMsgBox 共合并了 & Num & 个工作薄下的全部工作表。如下： & Chr(13) & WbN, vbInformation, 提示End Sub具体操作：在工作簿目录下新建一工作簿，工具-宏-编辑器-插入模块-粘贴代码=运行excel 如何将一个工作簿中的多个工作表合并到一张工作表上打开你的工作簿 新建一个工作表 在这个工作表的标签上右键 查看代码 你把下面的代码复制到里边去，然后 上面有个运行 运行子程序就可以了，代码如下，如果 出现问题你可以尝试工具 宏 宏安全性里把那个降低为中或者低再试试Sub 合并当前工作簿下的所有工作表() Application.ScreenUpdating = FalseFor j = 1 To Sheets.CountIf Sheets(j).Name ActiveSheet.Name Then X = Range(A65536).End(xlUp).Row + 1 Sheets(j).UsedRange.Copy Cells(X, 1)End If NextRange(B1).Select Application.ScreenUpdating = TrueMsgBox 当前工作簿下的全部工作表已经合并完毕！, vbInformation, 提示End Sub把同一工作簿多张工作表合并到同一张工作表1新建一个工作表放在最左边，ALT + F11 键打开代码框-插入-模块-复制以下代码ALT + F8 键打开，运行该代码即可Sub 合并()For I = 2 To Sheets.Count如果工作表的第一行都一样，就把下面 Rows(1 &的 1 改成 2 就好了Sheets(I).Rows(1 & : & Sheets(I).Range(A60000).End(xlUp).Row). _ Copy Range(A & Range(A60000).End(xlUp).Row + 1)Next End Sub批量将多个 excel 中的多个工作簿合并到一个 excel 中将要合并的 excel 放到一个文件夹中，在这个目录中新建一个 excel,运行以下代码Sub CombineFiles()Dim pathAs StringDim FileNameAs StringDim LastCellAs RangeDim WkbAs WorkbookDim WSAs WorksheetDim ThisWBAs StringDim MyDir As StringMyDir = ThisWorkbook.path & ChDrive Left(MyDir, 1) find all the excel files ChDir MyDirMatch = Dir$()ThisWB = ThisWorkbook.Name Application.EnableEvents = False Application.ScreenUpdating = False path = MyDirFileName = Dir(path & *.xls, vbNormal) Do Until FileName = If FileName ThisWB ThenSet Wkb = Workbooks.Open(FileName:=path & & FileName) For Each WS In Wkb.WorksheetsSet LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)If LastCell.Value = And LastCell.Address = Range($A$1).Address Then ElseWS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) End IfNext WS Wkb.Close FalseEnd IfFileName = Dir() LoopApplication.EnableEvents = True Application.ScreenUpdating = TrueSet Wkb = Nothing Set LastCell = NothingEnd Sub“”“”At the end, Xiao Bian gives you a passage. Minand once said, people who learn to learn are very happy people. In every wonderful life, learning is an eternal theme. As a professional clerical and teaching position, I understand the importance of continuous learning, life is diligent, nothing can be gained, only continuous learning can achieve better self. Only by constantly learning and mastering the latest relevant knowledge, can employees from all walks of life keep up with the pace of enterprise development and innovate to meet the needs of the market. This document is also edited by my studio professionals, there may be errors in the document, if there are errors, please correct, thank you!