EXCEL常用VBA代码

删除B列中字符串数值少于21的单元格所在的行Sub删除行()r=Range(B65536).End(xlUp).Row'行数Forh=rTo1Step-1IfCells(h,2)21ThenCells(h,2).EntireRow.DeleteNextEndSub-------------------------【工作表合并】将同一工作簿中的所有工作表合并到一个工作表中新建一个工作表，写入代码[在新建的工作表标签处右键查看代码（找不到的直接按一下alt+F11)把下面的代码复制进去然后点上面的运行运行子程序即可]：Sub合并当前工作簿下的所有工作表()Application.ScreenUpdating=FalseForj=1ToSheets.CountIfSheets(j).NameActiveSheet.NameThenX=Range(A65536).End(xlUp).Row+1Sheets(j).UsedRange.CopyCells(X,1)EndIfNextRange(B1).SelectApplication.ScreenUpdating=TrueMsgBox当前工作簿下的全部工作表已经合并完毕！,vbInformation,提示EndSub*********************************************************代码这样写也行：Subc()Fori=Sheets.CountTo2Step-1Sheets(i).SelectSheets(i).UsedRange.CopySheets(1).SelectCells(Cells(65000,1).End(xlUp).Row+1,1).SelectActiveSheet.Paste'Sheets(i).DeleteNextiEndSub************************************************************把一个工作簿中的所有表单合并成一个表单，怎么去掉重复的表头、标题行？方法如下：Subc()Fori=Sheets.CountTo2Step-1Sheets(i).UsedRange.Offset(1).CopySheets(1).Cells(65536,1).End(xlUp).Offset(1)NextiEndSub说明：函数OFFSET(reference,rows,cols,height,width)以指定的引用为参照系，通过给定偏移量得到新的引用。返回的引用可以为一个单元格或单元格区域。并可以指定返回的行数或列数。通俗的讲就是OFFSET(参考单元格，移动的行数，移动的列数，所要引用的行数，所要引用的列数）参考《关于offset函数》第三行中第一个offset(1)是假设要要去掉的表头行数，如果有2行表头，就改成offset(2)，要去掉几行表头括号中的数字就改成几。第二个offset(1)表示合并以后表格与表格之间要间隔的空行，offset(1)表示不留空行，offset(2)表示间隔1行空行，以此类推。也可以这样写：Subc()Fori=Sheets.CountTo2Step-1Sheets(i).UsedRange.Offset(2).CopySheets(1).Cells(Cells(65536,1).End(xlUp).Row+1,1).Offset(0)‘这个offset(0)可以不要NextiEndSub****************************************************************或者用以下宏代码将同一工作簿中的所有工作表合并到一个新建的工作表中按ALT+F11调出ＶＢＡ窗口，插入一个模块，然后把下面的代码复制进去。Subhz()SetNewSheet=Sheets.Add(Type:=xlWorksheet)'生成一个新表Sheets(NewSheet.Index).MoveBefore:=Sheets(1)'将此新表移动到最前面Fori=2ToWorksheets.CountSheets(i).UsedRange.CopyNewSheet.Cells([a65536].End(xlUp).Row+2,1)'将其他表的已使用区域复制到新表中NextiMsgBox合并完成EndSub这段代码很简单，其中第四行中用FOR循环得到当前工作簿中的所有工作表，第五行中使用UsedRange得到每个工作表的“已使用区域”，然后用copy方法把这些“已使用区域”中的内容复制到新建工作表中。语句Cells([a65536].End(xlUp).Row+2,1)的作用是得到新建工作表的Ａ列中的最后空白单元格(即要在哪个位置粘贴)，加2的作用是使每次复制数据间隔2行空格（此处应表示间隔1行空格，加1的话，表示合并的表格与表格之间不留空格）。回到EXCEL窗口，执行“工具-宏-宏”中的“hz”宏就会自动合并工作表了。（经本人测试，不能使用右键点击标签查看代码再粘入代码的方式，应该运用菜单栏插入模块的方式）---------------------------------------------------------------【工作簿合并】将需要合并的工作簿文件放置在一个文件夹中，并新建一个工作簿，写入代码：Sub合并工作薄()DimFilesToOpenDimxAsIntegerOnErrorGoToErrHandlerApplication.ScreenUpdating=FalseFilesToOpen=Application.GetOpenFilename_(FileFilter:=MicroSoftExcel文件(*.xls),*.xls,_MultiSelect:=True,Title:=要合并的文件)IfTypeName(FilesToOpen)=BooleanThenMsgBox没有选中文件GoToExitHandlerEndIfx=1Whilex=UBound(FilesToOpen)Workbooks.OpenFilename:=FilesToOpen(x)Sheets().MoveAfter:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)x=x+1WendExitHandler:Application.ScreenUpdating=TrueExitSubErrHandler:MsgBoxErr.DescriptionResumeExitHandlerEndSub------------------------显示隐藏的工作表SubShowAllSheets()'使当前工作簿中的所有工作表都显示(即将隐藏的工作表也显示)DimwsAsWorksheetForEachwsInSheetsws.Visible=TrueNextwsEndSub--------------------------------------------------------根据Sheet2中的数据，检查Sheet1中的重复数据，并且进行后续的操作（将重复数据删除或者拷贝出来）的操作。Application.ScreenUpdating=FalseC=2'第一个工作表检测B列X=1'第一条检测结果放在第1行Count=1First_sheet_row=Sheets(1).Cells(65536,C).End(xlUp).RowSecond_sheet_row=Sheets(2).Cells(65536,C).End(xlUp).RowDimTo_be_deleted(5369)AsStringForj=1To5368To_be_deleted(j)=Trim(CStr(Sheets(2).Cells(j,2).Value))NextjFori=1ToFirst_sheet_rowFirst_value=Trim(CStr(Sheets(1).Cells(i,C).Value))Forj=1To5368'MsgBoxTo_be_deleted(j)IfFirst_value=To_be_deleted(j)ThenSheets(1).Range(A&CStr(i)&:Ag&i).DeleteSheets(2).Cells(j,4).Value=Copied'Sheets(2).Cells(j,3).Value=Copied'Application.CutCopyMode=False'Sheets(1).Range(A&CStr(i)&:Ag&i).Copy'Sheets(3).PasteDestination:=Sheets(3).Range(A&i)'Sheets(3).PasteCount=Count+1i=i-1EndIfNextjNextiApplication.ScreenUpdating=TrueMsgBox共删除了&Count这个脚本中有一些优化的地方，原来进行数据比较时，都是使用直接Cell(x,y)的方式访问并对比，另外也是分别循环，效率非常低，Excel一直处于假死的状态。后来，先将比较小的一份数据拷贝到数组中，然后再进行循环，这样效率就提高了很多。----------------------------------------------------------合并目录中具有同样数据格式的多个Excel文件DimMyPath,MyName,AWbNameDimWbAsWorkbook,WbNAsStringDimGAsLongDimNumAsLongDimBOXAsStringApplication.ScreenUpdating=FalseMyPath=ActiveWorkbook.PathMyName=Dir(MyPath&\&*.xls)AWbName=ActiveWorkbook.NameNum=0DoWhileMyNameIfMyNameAWbNameThenSetWb=Workbooks.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).SelectApplication.ScreenUpdating=TrueMsgBox共合并了&Num&个工作薄下的全部工作表。如下：&Chr(13)&WbN,vbInformation,提示-------------------------------------------------------------奇偶页分别打印Sub奇偶页分别打印()Dimi%,Ps%Ps=ExecuteExcel4Macro(“GET.DOCUMENT(50)”)‘总页数MsgBox“现在打印奇数页,按确定开始.”Fori=1ToPsStep2ActiveSheet.PrintOutfrom:=i,To:=iNextiMsgBox“现在打印偶数页,按确定开始.”Fori=2ToPsStep2ActiveSheet.PrintOutfrom:=i,To:=iNextiEndSub--------------------------------------------------------将A列最后数据行以上的所有B列图片大小调整为所在单元大小Sub将A列最后数据行以上的所有B列图片大小调整为所