宏代码-合并工作表

宏代码—工作表合并一、关于宏的EXCEL设置1.设置快捷宏图标：文件—EXCEL选项-常用-在功能区显示“开发工具”选项卡打钩2.删除宏：宏-选中相应的宏-删除3.取消出现安全隐私警告：EXCEL选项-信任中心-信任中心设置-个人信息选项-将”保存时从文件属性中删除个人信息“前面的勾去掉二、合并当前工作簿下的所有工作表1.我们现在开始合并，首先要在最前页新建一个工作表。如图：HYPERLINK"http://jingyan.baidu.com/album/19020a0ad8080d529d28422a.html?picindex=2"\t"_self"步骤阅读2.在新建的sheet表中“右键”，找到“查看代码”，然后看到宏计算界面。如图所示：HYPERLINK"http://jingyan.baidu.com/album/19020a0ad8080d529d28422a.html?picindex=3"\t"_self"步骤阅读HYPERLINK"http://jingyan.baidu.com/album/19020a0ad8080d529d28422a.html?picindex=4"\t"_self"步骤阅读看到宏计算界面，我们就只需要把下面的代码复制进去，代码如下，效果如下：Sub合并当前工作簿下的所有工作表()Application.ScreenUpdating=FalseForj=1ToSheets.Count  IfSheets(j).Name<>ActiveSheet.NameThen    X=Range("A65536").End(xlUp).Row+1    Sheets(j).UsedRange.CopyCells(X,1)  EndIfNextRange("B1").SelectApplication.ScreenUpdating=TrueMsgBox"当前工作簿下的全部工作表已经合并完毕！",vbInformation,"提示"EndSub或者如下：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 SubHYPERLINK"http://jingyan.baidu.com/album/19020a0ad8080d529d28422a.html?picindex=5"\t"_self"步骤阅读53.点击工具栏上面的“运行”下的“运行子过程/用户窗体”就可以了，合并完之后会有提示。提示完成之后就可以把宏计算界面关闭了。如图所示：HYPERLINK"http://jingyan.baidu.com/album/19020a0ad8080d529d28422a.html?picindex=6"\t"_self"步骤阅读4.合并完成后记得删除宏，详细操作见一5.删除多余的首行标题：工作表全选—自动筛选—选择列（建议选择文本选项少的列）--勾选重复的标题与空白—删除重复标题与空白三、合并当前目录下所有工作簿的全部工作表1.我们需要把多个excel表都放在同一个文件夹里面，并在这个文件夹里面新建一个excel。如图所示：步骤阅读2.用microsoftexcel打开新建的excel表，并右键单击sheet1，找到“查看代码”，单击进去。进去之后就看到了宏计算界面。如图所示：HYPERLINK"http://jingyan.baidu.com/album/f0062228d16ba9fbd3f0c82b.html?picindex=3"\t"_self"步骤阅读HYPERLINK"http://jingyan.baidu.com/album/f0062228d16ba9fbd3f0c82b.html?picindex=4"\t"_self"步骤阅读3.然后我们把下面这些宏计算的代码复制进去（注意XLS或者XLSX），代码如下，如图所示：Sub合并当前目录下所有工作簿的全部工作表()DimMyPath,MyName,AWbNameDimWbAsWorkbook,WbNAsStringDimGAsLongDimNumAsLongDimBOXAsStringApplication.ScreenUpdating=FalseMyPath=ActiveWorkbook.PathMyName=Dir(MyPath&"\"&"*.xls")AWbName=ActiveWorkbook.NameNum=0DoWhileMyName<>""IfMyName<>AWbNameThenSetWb=Workbooks.Open(MyPath&"\"&MyName)Num=Num+1WithWorkbooks(1).ActiveSheet.Cells(.Range("B65536").End(xlUp).Row+2,1)=Left(MyName,Len(MyName)-4)ForG=1ToSheets.CountWb.Sheets(G).UsedRange.Copy.Cells(.Range("B65536").End(xlUp).Row+1,1)NextWbN=WbN&Chr(13)&Wb.NameWb.CloseFalseEndWithEndIfMyName=DirLoopRange("B1").SelectApplication.ScreenUpdating=TrueMsgBox"共合并了"&Num&"个工作薄下的全部工作表。如下："&Chr(13)&WbN,vbInformation,"提示"EndSubHYPERLINK"http://jingyan.baidu.com/album/f0062228d16ba9fbd3f0c82b.html?picindex=5"\t"_self"步骤阅读4.然后找到工具栏上面的“运行”下的“运行子过程/用户窗体”HYPERLINK"http://jingyan.baidu.com/album/f0062228d16ba9fbd3f0c82b.html?picindex=6"\t"_self"步骤阅读5.合并完成后记得删除宏，详细操作见一6.删除多余的首行标题：工作表全选—自动筛选—选择列（建议选择文本选项少的列）--勾选重复的标题与空白—删除重复标题与空白四、多个Excel工作簿的第一个工作表合并成一个新的工作簿1、将需要合并的excel工作簿文件放置在一个文件夹中。2、在该文件夹中，新建立一个新的excel工作簿文件。3、打开新建立的excel工作簿文件，将鼠标移动到下方工作表名称sheet1上右键，选择查看代码。4、在弹出的代码编辑窗口中，输入代码。5、在代码窗口中，粘贴下列代码：PrivateSub合并工作薄()Dimf_nameAsStringDimbok1AsWorkbook,bok2AsWorkbookSetbok2=Nothingf_name=Dir(ThisWorkbook.Path&"\*.*")'获得该目录下的所有EXCEL文件DoWhilef_name<>""'开始执行循环Iff_name<>ThisWorkbook.NameThen'如果当前的文件不是代码所在文件，执行合并操作Setbok1=Workbooks.Open(ThisWorkbook.Path&"\"&f_name)'打开被合并的文件Ifbok2IsNothingThen'合并后的文件是否存在bok1.Sheets(1).Copy'如果合并后的文件不存在，则创建一个Setbok2=ActiveWorkbookElsebok1.Sheets(1).CopyBefore:=bok2.Sheets(1)'如果合并后的文件存在，则将被合并文件的第一个工作表复制到合并文件中。EndIfbok1.Close'关闭被合并文件EndIff_name=Dir()'获取下一个被合并文件名LoopEndSub6、点击菜单栏运行-运行子过程-用户窗体。关闭代码输入窗口。打开excel工作簿，可以看到下方已经将之前工作簿中的工作表都复制到了这一新建工作簿中。五、多个Excel工作簿的所有工作表（非空白）合并成一个新的工作簿1、将需要合并的excel工作簿文件放置在一个文件夹中。2、在该文件夹中，新建立一个新的excel工作簿文件。3、打开新建立的excel工作簿文件，将鼠标移动到下方工作表名称sheet1上右键，选择查看代码。4、在弹出的代码编辑窗口中，输入代码。5、在代码窗口中，粘贴下列代码：Sub合并工作薄()DimPathAsStringDimFileNameAsStringDimLastCellAsRangeDimWkbAsWorkbookDimWSAsWorksheetDimThisWBAsStringDimMyDirAsStringMyDir=ThisWorkbook.Path&"\"'ChDriveLeft(MyDir,1)'findalltheexcelfiles'ChDirMyDir'Match=Dir$("")ThisWB=ThisWorkbook.NameApplication.EnableEvents=FalseApplication.ScreenUpdating=FalsePath=MyDirFileName=Dir(Path&"\*.xls",vbNormal)DoUntilFileName=""IfFileName<>ThisWBThenSetWkb=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