Excel工作表到时自动删除公式的宏代码

用宏删除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