VBA常用代码.doc

1. 遍历所有已打开的word文档ForEachdocOpenedInDocumentsNextdocOpened2. Word 将目录下所有文档转换为txt，并删除原文档Sub目录下doc转txt()目录下所有word文档转为txt，并删除word文档保存在原目录遍历所有文件夹，把带路径的文件名存入字典OnErrorResumeNextDimPathAsString,tPath为路径,t用于计算程序执行花费的时间Setobjshell=CreateObject(Shell.Application)Setobjfolder=objshell.BrowseForFolder(0,选择文件夹,0,0)IfNotobjfolderIsNothingThenPath=objfolder.self.Path&Setobjfolder=NothingSetobjshell=Nothing创建字典用于存储路径和文件名DimDicPath,DicFile,iAsInteger,Ke,ContentNameAsString,FileNameAsString,MsgTxtSetDicPath=CreateObject(Scripting.Dictionary)SetDicFile=CreateObject(Scripting.Dictionary)DicPath.AddPath,i=0存所有路径DoWhileiDicPath.countKe=DicPath.keysContentName=Dir(Ke(i),vbDirectory)DoWhileContentName若有子文件夹，则添加跳过当前的目录及上层目录IfContentName.AndContentName.ThenIfGetAttr(Ke(i)&ContentName)=vbDirectoryThenDicPath.Add(Ke(i)&ContentName&),EndIfEndIfContentName=DirLoopi=i+1Loop存所有doc文件名ForEachKeInDicPath.keysFileName=Dir(Ke&*.doc)DoWhileFileNameDicFile.Add(Ke&FileName),FileName=DirLoopNextKe打开文件Application.DisplayAlerts=wdAlertsNoneDimmyDocForEachKeInDicFile.keysSetmyDoc=Documents.Open(Ke)原路径另存为TXTActiveDocument.SaveAs2FileName:=myDoc.Path&Left(myDoc.Name,InStrRev(myDoc.Name,.)-1)&.txt,FileFormat:=wdFormatText处理完成后关闭并删除原word文档ActiveDocument.CloseKillKeNextKeMsgBoxDone！EndSub3. 获取网页源代码DimhttpRequestAsObjectSethttpRequest=CreateObject(MSXML2.XMLHTTP.3.0)httpRequest.OpenGET,/tmp/autoproduct/ccq2/ci/cha_num.php?pid=&ItemID&sdate=&sDate&edate=&eDate,FalsehttpRequest.SendtxtTemp=httpRequest.responseText或txtTemp=StrConv(httpRequest.responsebody,vbUnicode)4. Excel合并相同文件名的单元格，不同文件名的行填充不同的背景色DimiAsInteger,jAsInteger,kAsIntegeri用于遍历，j用于计数须合并的行数,k用于填充颜色i=1k=0WithwbTmpDoWhile.Cells(i+1,1)j=1DoWhile.Cells(i,1)=.Cells(i+j,1)j=j+1LoopIfj1Then.Range(.Cells(i,1),.Cells(i+j-1,1).MergeEndIfIf(kMod2=1)Then.Cells(i,1).Resize(j,5).Interior.Color=5296274Else:.Cells(i,1).Resize(j,5).Interior.Color=49407EndIfk=k+1i=i+jLoopEndWith5. 若同目录下不存在某文件夹，则创建Dimsrsr=Dir(ThisWorkbook.Path&上海办待导入txt,vbDirectory)Ifsr=ThenMkDirThisWorkbook.Path&上海办待导入txtEndIf6. Word替换昨日今日去年之类的字眼Sub替换昨今去()DimYesterday_DayAsInteger,YesterdayAsString,Yesterday_MonthAsInteger,Yesterday_YearAsIntegerDimToday_DayAsInteger,Today_MonthAsInteger,Today_YearAsIntegerYesterday=DateAdd(d,-1,Date)Yesterday_Day=Day(Yesterday)Yesterday_Month=Month(Yesterday)Yesterday_Year=Year(Yesterday)Today_Day=Day(Date)Today_Month=Month(Date)Today_Year=Year(Date)选择性粘贴Selection.PasteAndFormat(wdPasteDefault)Selection.Find.ClearFormattingSelection.Find.Replacement.ClearFormatting取消所有超链接DimccAsFieldForEachccInActiveDocument.FieldsIfcc.Type=wdFieldHyperlinkThencc.UnlinkEndIfNextSetcc=Nothing替换昨天、昨日WithSelection.Find.Text=昨天日1.Replacement.Text=Yesterday_Month&月&Yesterday_Day&日.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll替换今天、今日WithSelection.Find.Text=今天日1.Replacement.Text=Today_Month&月&Today_Day&日.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll替换今年WithSelection.Find.Text=今年.Replacement.Text=Today_Year&年.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll替换去年WithSelection.Find.Text=去年.Replacement.Text=Today_Year-1&年.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删象屿期货的段前符号WithSelection.Find.Text=ChrW(61548).Replacement.Text=.Forward=True.Wrap=wdFindContinue.MatchByte=True.MatchWildcards=FalseEndWithSelection.Find.ExecuteReplace:=wdReplaceAll手动换行符替换成回车符WithSelection.Find.Text=l.Replacement.Text=p.Forward=True.Wrap=wdFindContinue.MatchByte=True.MatchWildcards=FalseEndWithSelection.Find.ExecuteReplace:=wdReplaceAll段与段顶多只隔一行，将任意个回车符号替换成二个WithSelection.Find.Text=(13).Replacement.Text=pp.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll全选+剪切Selection.WholeStorySelection.CutEndSub7. 提取word文档里的图片Sub存成html()Application.ScreenUpdating=FalseDimFileNameAsStringFileName=InputBox(请输入文件名)Selection.CopyDocuments.AddDocumentType:=wdNewBlankDocumentSelection.PasteAndFormat(wdPasteDefault)若无目录则创建IfDir(D:backup140591桌面报告temp,vbDirectory)=ThenMkDirD:backup140591桌面报告tempActiveDocument.SaveAsFileName:=D:backup140591桌面报告temp&FileName,FileFormat:=wdFormatHTML,_LockComments:=False,Password:=,AddToRecentFiles:=True,WritePassword_:=,ReadOnlyRecommended:=False,EmbedTrueTypeFonts:=False,_SaveNativePictureFormat:=False,SaveFormsData:=False,SaveAsAOCELetter:=_FalseActiveWindow.View.Type=wdWebView段与段顶多只隔一行，将任意个回车符号替换成二个WithSelection.Find.Text=(13).Replacement.Text=pp.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll全选+剪切Selection.WholeStorySelection.CutActiveDocument.CloseFalseApplication.ScreenUpdating=TrueMsgBox已完成！EndSub8. Word 删除新闻中的多余代码和文字Sub新闻排版()选择性粘贴Selection.PasteAndFormat(wdPasteDefault)Selection.Find.ClearFormattingSelection.Find.Replacement.ClearFormatting删图片DimoInlineShapeAsInlineShapeForEachoInlineShapeInActiveDocument.InlineShapesoInlineShape.DeleteNext取消所有超链接DimccAsFieldForEachccInActiveDocument.FieldsIfcc.Type=wdFieldHyperlinkThencc.UnlinkEndIfNextSetcc=Nothing删(微博)微博WithSelection.Find.Text=（(微博）).Replacement.Text=.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删(博客,微博)WithSelection.Find.Text=(博客,微博).Replacement.Text=pp.Forward=True.Wrap=wdFindContinue.MatchByte=True.MatchWildcards=FalseEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删象屿期货的段前符号WithSelection.Find.Text=ChrW(61548).Replacement.Text=.Forward=True.Wrap=wdFindContinue.MatchByte=True.MatchWildcards=FalseEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删小标题后的/WithSelection.Find.Text=/p.Replacement.Text=p.Forward=True.Wrap=wdFindContinue.MatchByte=True.MatchWildcards=FalseEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删股票代码WithSelection.Find.Text=-09.1,s1,-09.1,s1,-09. .Replacement.Text=.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删股票涨跌值WithSelection.Find.Text=-09.Replacement.Text=.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删2.98%资金研报WithSelection.Find.Text=-09.Replacement.Text=.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll删(600648,股吧)WithSelection.Find.Text=096,股吧基金2,3 .Replacement.Text=.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll手动换行符替换成回车符WithSelection.Find.Text=l.Replacement.Text=p.Forward=True.Wrap=wdFindContinue.MatchByte=True.MatchWildcards=FalseEndWithSelection.Find.ExecuteReplace:=wdReplaceAll段与段顶多只隔一行，将任意个回车符号替换成二个WithSelection.Find.Text=(13).Replacement.Text=pp.Forward=True.Wrap=wdFindContinue.MatchByte=False.MatchWildcards=TrueEndWithSelection.Find.ExecuteReplace:=wdReplaceAll全选+剪切Selection.WholeStorySelection.CutEndSub9. Excel双击则复制单元格内容到剪切板PrivateSubWorksheet_BeforeDoubleClick(ByValTargetAsRange,CancelAsBoolean)WithCreateObject(new:1C3B4210-F441-11CE-B9EA-00AA006B1A69).SetTextTarget.PutInClipboardEndWithEndSub10. 用对话框打开Excel文件iFileName=Application.GetOpenFilename(Excel文件(*.xlsx;*.xls),*.xlsx;*.xls)11. Excel按指定列升序排列Withwbf.Sort.SortFields.Clear.SortFields.AddKey:=Range(B1),SortOn:=xlSortOnValues,Order:=xlAscendingdescending，递减。Ascending，递增.SetRangeRange(A1).CurrentRegion排序区域.Header=xlGuess第一行包含标题.MatchCase=False不区分大小写.Orientation=xlTopToBottom.SortMethod=xlPinYin.ApplyEndWith12. 汉字编码成URL用的字符串PublicFunctionEscape(ByValstrTextAsString)AsStringSetJS=CreateObject(msscriptcontrol.scriptcontrol)JS.Language=JavaScriptEscape=JS.eval_r(encodeURI(&Replace(strText,)&);)EndFunction13. Excel汇总同目录文件SubHzWb()DimbtAsRange,rAsLong,cAsLongr=11是表头的行数c=88是表头的列数Range(Cells(r+1,A),Cells(65536,c).ClearContents清除汇总表中原表数据Application.ScreenUpdating=FalseDimFileNameAsString,wbAsWorkbook,ErowAsLong,fnAsString,arrAsVariantFileN