您好,欢迎访问三七文档
当前位置:首页 > 办公文档 > 总结/报告 > EXCEL-VBA-实用代码收集
图片切换Sub显示开或关()IfActiveSheet.Shapes(Picture2).Visible=TrueThenActiveSheet.Shapes(Picture1).Visible=TrueActiveSheet.Shapes(Picture2).Visible=FalseElseActiveSheet.Shapes(Picture2).Visible=TrueActiveSheet.Shapes(Picture1).Visible=FalseEndIfEndSub当前单元格输入数字自动分解PrivateSubWorksheet_Change(ByValTargetAsRange)IfTarget.Column1ThenExitSubIfLen(Target(1,1))1ThenDimoJsAsObjectSetoJs=CreateObject(ScriptControl):oJs.Language=JScriptTarget(1,2).Resize(1,254).ClearContentsTarget.Resize(1,Len(Target))=Split(oJs.eval('&Target&'.match(/./g);),,)EndIfEndSubword批量修改图片大小——固定长宽Subsetpicsize()'设置图片大小Dimn'图片个数OnErrorResumeNext'忽略错误Forn=1ToActiveDocument.InlineShapes.Count'InlineShapes类型图片ActiveDocument.InlineShapes(n).Height=400'设置图片高度为400pxActiveDocument.InlineShapes(n).Width=300'设置图片宽度300pxNextnForn=1ToActiveDocument.Shapes.Count'Shapes类型图片ActiveDocument.Shapes(n).Height=400'设置图片高度为400pxActiveDocument.Shapes(n).Width=300'设置图片宽度300pxNextnEndSub批量修改图片大小——按比例缩放篇Subsetpicsize()'设置图片大小Dimn'图片个数DimpicwidthDimpicheightOnErrorResumeNext'忽略错误Forn=1ToActiveDocument.InlineShapes.Count'InlineShapes类型图片picheight=ActiveDocument.InlineShapes(n).Heightpicwidth=ActiveDocument.InlineShapes(n).WidthActiveDocument.InlineShapes(n).Height=picheight*1.1'设置高度为1.1倍ActiveDocument.InlineShapes(n).Width=picwidth*1.1'设置宽度为1.1倍NextnForn=1ToActiveDocument.Shapes.Count'Shapes类型图片picheight=ActiveDocument.Shapes(n).Heightpicwidth=ActiveDocument.Shapes(n).WidthActiveDocument.Shapes(n).Height=picheight*1.1'设置高度为1.1倍ActiveDocument.Shapes(n).Width=picwidth*1.1'设置宽度为1.1倍NextnEndSub批量给图片加边框DimiAsIntegerFori=1ToActiveDocument.InlineShapes.CountWithActiveDocument.InlineShapes(i)With.Borders(wdBorderLeft).LineStyle=wdLineStyleSingle.LineWidth=wdLineWidth100pt.Color=wdColorAutomaticEndWithWith.Borders(wdBorderRight).LineStyle=wdLineStyleSingle.LineWidth=wdLineWidth100pt.Color=wdColorAutomaticEndWithWith.Borders(wdBorderTop).LineStyle=wdLineStyleSingle.LineWidth=wdLineWidth100pt.Color=wdColorAutomaticEndWithWith.Borders(wdBorderBottom).LineStyle=wdLineStyleSingle.LineWidth=wdLineWidth100pt.Color=wdColorAutomaticEndWith.Borders.Shadow=FalseEndWithWithOptions.DefaultBorderLineStyle=wdLineStyleSingle.DefaultBorderLineWidth=wdLineWidth100pt.DefaultBorderColor=wdColorAutomaticEndWithNexti锁定文件名PrivateSubWorkbook_Open()IfThisWorkbook.Name三八节.xlsThenApplication.DisplayAlerts=FalseApplication.QuitEndIfEndSub将数值转换为文本[程序扩展]可以将程序代码1和程序代码2略加改动,将一个字符附加到所选单元格的开头。如将cell.Value='&cell.Value换成cell.Value=”I”&cell.Value,则在所选单元格开头添加字符“I”,即可统一单元格开始形式。[程序代码1]Sub数值转换为文本1()'通过添加'号DimcellAsRangeForEachcellInSelectionIfNotcell.HasFormulaThenIfNotIsEmpty(cell)Thencell.Value='&cell.ValueEndIfEndIfNextEndSub[程序代码2]Sub数值转换成文本2()'只对数字单元格进行操作DimcellAsRangeForEachcellInSelectionIfNotcell.HasFormulaThenIfNotIsEmpty(cell)ThenIfIsNumeric(cell)Thencell.Value='&cell.Value'可根据需要变换字符EndIfEndIfEndIfNextEndSub[程序代码3]Sub数值转换为文本3()'通过格式DimcellAsRangeForEachcellInSelectionIfNotcell.HasFormulaThenIfNotIsEmpty(cell)ThenSelection.NumberFormatLocal=@EndIfEndIfNextEndSub关闭并保存所有工作簿OptionExplicitSubCloseAllWorkbooks()DimBookAsWorkbookForEachBookInWorkbooksIfBook.NameThisWorkbook.NameThenBook.Closesavechanges:=TrueEndIfNextBookThisWorkbook.Closesavechanges:=TrueEndSub关闭工作簿并将它彻底删除OptionExplicitSubKillMe()WithThisWorkbook.Saved=True.ChangeFileAccessMode:=xlReadOnlyKill.FullName.CloseFalseEndWithEndSubA列输出排列组合Subpailie()DimsAsString,x()AsStringDimstarttimeAsSingle,endtimeAsSingleDimiAsLong,jAsInteger,kAsInteger,NumAsLong,nAsIntegerDimALL(),TEMP1AsLong,TEMP2AsLong,arr()AsStrings=InputBox(请输入不重复的字母或数字)n=Len(s)'元素个数ReDimx(n-1)Fori=1Tonx(i-1)=Mid(s,i,1)Nextstarttime=Timer'开始计时Num=1Fori=1TonNum=Num*i'递归计算n!NextReDimarr(1ToNum,1To1)Fori=1ToNumReDimALL(1Ton)'初始化数组allALL(1)=x(0)TEMP1=iForj=2TonTEMP2=TEMP1ModjTEMP1=TEMP1\jIfTEMP2=0ThenALL(j)=x(j-1)'temp2为0则放在最后ElseFork=jToTEMP2+1Step-1ALL(k)=ALL(k-1)'temp2之后的元素后移一位NextALL(TEMP2)=x(j-1)'temp2不为0则置于第temp2个元素前EndIfNextarr(i,1)=Join(ALL,)'输出Nextendtime=TimerApplication.ScreenUpdating=FalseRange(a1).Resize(Num,1)=arrApplication.ScreenUpdating=TrueMsgBox共&Num&种排列!用时&endtime-starttime&秒!EndSub同薄汇总工作表Submysub()Application.ScreenUpdating=FalseDimshAsWorksheet,aaAsLong,bbAsLong,ccAsLong,ddAsLongdd=Sheets(汇总).[IV1].End(1).ColumnSheets(汇总).Range(Cells(2,2),Cells(65536,dd)).ClearContentsForEachshInWorksheetsIfsh.Name汇总Thenbb=Sheets(汇总).[b65536].End(xlUp).Row+1aa=sh.[b65536].End(xlUp).Rowcc=sh.[IV1].End(1).Columnsh.Range(sh.Cells(2,2),sh.Cells(aa,cc)).CopySheets(汇总).Cells(bb,2).PasteSpecialxlPasteValuesEndIfNextshApplication.ScreenUpdating=TrueEndSub异薄SHEET1汇总PrivateSubCommandButton2_Click()Application.ScreenUpdating=FalseDimi&,LastRow&,Path$,FileName$,TWB$,WBAsWorkbookPath=ThisWorkbook.Path&\FileName=Dir(Path&*.xls)TWB=ThisWorkbook.NameRange(A1:X65536).ClearContentsDoWhileLen(FileName)IfFileNameTWBThenSetWB=Workbooks.Open(Path&FileName)WithWB.Worksheets(1)LastRow=.Range(A65536).End(xlUp).RowIfLastRow1Then.Range(A8:x8).CopyThisWorkbook.Sheets(汇总).Range(A65536).End(xlUp)(2).PasteSpecialPaste:=xl
本文标题:EXCEL-VBA-实用代码收集
链接地址:https://www.777doc.com/doc-4727818 .html