《excel合并工作簿和工作表的代码》由会员分享，可在线阅读，更多相关《excel合并工作簿和工作表的代码（3页珍藏版）》请在金锄头文库上搜索。
1、把多个工作簿合并到一个工作簿作为新工作簿的一张表(宏代码)Sub合并当前目录下所有工作簿的全部工作表()DimMyPath,MyName,AWbNameDimWbAsWorkbook,WbNAsStringDimGAsLongDimNumAsLongDimBOXAsStringApplication.ScreenUpdating=FalseMyPath=ActiveWorkbook.PathMyName=Dir(MyPath&*.xls)AWbName=ActiveWorkbook.NameNum=0DoWhileMyNameIfMyNameAWbNameThenSetWb=Workbooks
2、.Open(MyPath&MyName)Num=Num+1WithWorkbooks(1).ActiveSheet.Cells(.Range(A65536).End(xlUp).Row+2,1)=Left(MyName,Len(MyName)-4)ForG=1ToSheets.CountWb.Sheets(G).UsedRange.Copy.Cells(.Range(A65536).End(xlUp).Row+1,1)NextWbN=WbN&Chr(13)&Wb.NameWb.CloseFalseEndWithEndIfMyName=DirLoopRange(A1).SelectApplica
3、tion.ScreenUpdating=TrueMsgBox共合并了&Num&个工作薄下的全部工作表。如下：&Chr(13)&WbN,vbInformation,提示EndSub具体操作：在工作簿目录下新建一工作簿，工具-宏编辑器插入模块-粘贴代码=运行excel如何将一个工作簿中的多个工作表合并到一张工作表上打开你的工作簿新建一个工作表在这个工作表的标签上右键查看代码你把下面的代码复制到里边去，然后上面有个运行运行子程序就可以了，代码如下，如果出现问题你可以尝试工具宏宏安全性里把那个降低为中或者低再试试Sub合并当前工作簿下的所有工作表()Application.ScreenUpdating
4、=FalseForj=1ToSheets.CountIfSheets(j).NameActiveSheet.NameThenX=Range(A65536).End(xlUp).Row+1Sheets(j).UsedRange.CopyCells(X,1)EndIfNextRange(B1).SelectApplication.ScreenUpdating=TrueMsgBox当前工作簿下的全部工作表已经合并完毕！,vbInformation,提示EndSub把同一工作簿多张工作表合并到同一张工作表1新建一个工作表放在最左边，ALT+F11键打开代码框-插入-模块-复制以下代码ALT+F8键打开
5、，运行该代码即可Sub合并()ForI=2ToSheets.Count如果工作表的第一行都一样，就把下面Rows(1&的1改成2就好了Sheets(I).Rows(1&:&Sheets(I).Range(A60000).End(xlUp).Row)._CopyRange(A&Range(A60000).End(xlUp).Row+1)NextEndSub批量将多个excel中的多个工作簿合并到一个excel中将要合并的excel放到一个文件夹中，在这个目录中新建一个excel,运行以下代码AsStringAsStringAsRangeAsWorkbookAsWorksheetAsStringS
6、ubCombineFiles()DimpathDimFileNameDimLastCellDimWkbDimWSDimThisWBDimMyDirAsStringMyDir=ThisWorkbook.path&ChDriveLeft(MyDir,1)findalltheexcelfilesChDirMyDirMatch=Dir$()ThisWB=ThisWorkbook.NameApplication.EnableEvents=FalseApplication.ScreenUpdating=Falsepath=MyDirFileName=Dir(path&*.xls,vbNormal)DoUn
7、tilFileName=IfFileNameThisWBThenSetWkb=Workbooks.Open(FileName:=path&FileName)ForEachWSInWkb.WorksheetsSetLastCell=WS.Cells.SpecialCells(xlCellTypeLastCell)IfLastCell.Value=AndLastCell.Address=Range($A$1).AddressThenElseWS.CopyAfter:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)EndIfNextWSWkb.CloseFalseEndIfFileName=Dir()LoopApplication.EnableEvents=TrueApplication.ScreenUpdating=TrueSetWkb=NothingSetLastCell=NothingEndSub
