For Each docOpened In Documents……
Next docOpened

2.Word 将目录下所有文档转换为txt，并删除原文档

Sub 目录下doc转txt()
'目录下所有word文档转为txt，并删除word文档
'保存在原目录'遍历所有文件夹，把带路径的文件名存入字典On Error Resume NextDim Path As String, t 'Path为路径,t用于计算程序执行花费的时间Set objshell = CreateObject("Shell.Application")Set objfolder = objshell.BrowseForFolder(0, "选择文件夹", 0, 0)If Not objfolder Is Nothing Then Path = objfolder.self.Path & "\"Set objfolder = NothingSet objshell = Nothing    '创建字典用于存储路径和文件名Dim DicPath, DicFile, i As Integer, Ke, ContentName As String, FileName As String, MsgTxtSet DicPath = CreateObject("Scripting.Dictionary")Set DicFile = CreateObject("Scripting.Dictionary")DicPath.Add Path, ""i = 0'存所有路径Do While i < DicPath.countKe = DicPath.keysContentName = Dir(Ke(i), vbDirectory)Do While ContentName <> ""'若有子文件夹，则添加'跳过当前的目录及上层目录If ContentName <> "." And ContentName <> ".." ThenIf GetAttr(Ke(i) & ContentName) = vbDirectory ThenDicPath.Add (Ke(i) & ContentName & "\"), ""End IfEnd IfContentName = DirLoopi = i + 1Loop'存所有doc文件名For Each Ke In DicPath.keysFileName = Dir(Ke & "*.doc")Do While FileName <> ""DicFile.Add (Ke & FileName), ""FileName = DirLoopNext Ke    '打开文件Application.DisplayAlerts = wdAlertsNoneDim myDocFor Each Ke In DicFile.keysSet myDoc = Documents.Open(Ke)'原路径另存为TXTActiveDocument.SaveAs2 FileName:=myDoc.Path & "\" & Left(myDoc.Name, InStrRev(myDoc.Name, ".") - 1) & ".txt", FileFormat:=wdFormatText'处理完成后关闭并删除原word文档ActiveDocument.CloseKill KeNext KeMsgBox "Done！"
End Sub

3.获取网页源代码

Dim httpRequest As ObjectSet httpRequest = CreateObject("MSXML2.XMLHTTP.3.0")httpRequest.Open "GET", "http://develop.100ppi.com/tmp/autoproduct/ccq2/ci/cha_num.php?pid=" & ItemID & "&sdate=" & sDate & "&edate=" & eDate, FalsehttpRequest.SendtxtTemp = httpRequest.responseText或txtTemp = StrConv(httpRequest.responsebody, vbUnicode)

4.Excel合并相同文件名的单元格，不同文件名的行填充不同的背景色

Dim i As Integer, j As Integer, k As Integer 'i用于遍历，j用于计数须合并的行数,k用于填充颜色
i = 1
k = 0
With wbTmpDo While .Cells(i + 1, 1) <> ""j = 1Do While .Cells(i, 1) = .Cells(i + j, 1)j = j + 1LoopIf j > 1 Then.Range(.Cells(i, 1), .Cells(i + j - 1, 1)).MergeEnd IfIf (k Mod 2 = 1) Then.Cells(i, 1).Resize(j, 5).Interior.Color = 5296274Else: .Cells(i, 1).Resize(j, 5).Interior.Color = 49407End Ifk = k + 1i = i + jLoop
End With

5.若同目录下不存在某文件夹，则创建

Dim sr
sr = Dir(ThisWorkbook.Path & "\上海办待导入txt", vbDirectory)
If sr = "" ThenMkDir ThisWorkbook.Path & "\上海办待导入txt"
End If

6.Word替换昨日今日去年之类的字眼

Sub 替换昨今去()
Dim Yesterday_Day As Integer, Yesterday As String, Yesterday_Month As Integer, Yesterday_Year As Integer
Dim Today_Day As Integer, Today_Month As Integer, Today_Year As Integer
Yesterday = 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'取消所有超链接Dim cc As FieldFor Each cc In ActiveDocument.FieldsIf cc.Type = wdFieldHyperlink Thencc.UnlinkEnd IfNextSet cc = Nothing'替换昨天、昨日With Selection.Find.Text = "昨[天日]{1}".Replacement.Text = Yesterday_Month & "月" & Yesterday_Day & "日".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'替换今天、今日With Selection.Find.Text = "今[天日]{1}".Replacement.Text = Today_Month & "月" & Today_Day & "日".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'替换今年With Selection.Find.Text = "今年".Replacement.Text = Today_Year & "年".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'替换去年With Selection.Find.Text = "去年".Replacement.Text = Today_Year - 1 & "年".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删象屿期货的段前符号With Selection.Find.Text = ChrW(61548).Replacement.Text = "".Forward = True.Wrap = wdFindContinue.MatchByte = True.MatchWildcards = FalseEnd WithSelection.Find.Execute Replace:=wdReplaceAll'手动换行符替换成回车符With Selection.Find.Text = "^l".Replacement.Text = "^p".Forward = True.Wrap = wdFindContinue.MatchByte = True.MatchWildcards = FalseEnd WithSelection.Find.Execute Replace:=wdReplaceAll'段与段顶多只隔一行，将任意个回车符号替换成二个With Selection.Find.Text = "(^13)@".Replacement.Text = "^p^p".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'全选+剪切Selection.WholeStorySelection.Cut
End Sub

7.提取word文档里的图片

Sub 存成html()
Application.ScreenUpdating = FalseDim FileName As StringFileName = InputBox("请输入文件名")Selection.CopyDocuments.Add DocumentType:=wdNewBlankDocumentSelection.PasteAndFormat (wdPasteDefault)'若无目录则创建If Dir("D:\backup\140591\桌面\报告temp\", vbDirectory) = "" Then MkDir "D:\backup\140591\桌面\报告temp\"ActiveDocument.SaveAs FileName:="D:\backup\140591\桌面\报告temp\" & FileName, FileFormat:=wdFormatHTML, _LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _FalseActiveWindow.View.Type = wdWebView'段与段顶多只隔一行，将任意个回车符号替换成二个With Selection.Find.Text = "(^13)@".Replacement.Text = "^p^p".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'全选+剪切Selection.WholeStorySelection.CutActiveDocument.Close False
Application.ScreenUpdating = True
MsgBox "已完成！"
End Sub

8.Word 删除新闻中的多余代码和文字

Sub 新闻排版()
'
''选择性粘贴Selection.PasteAndFormat (wdPasteDefault)Selection.Find.ClearFormattingSelection.Find.Replacement.ClearFormatting'删图片Dim oInlineShape As InlineShapeFor Each oInlineShape In ActiveDocument.InlineShapesoInlineShape.DeleteNext'取消所有超链接Dim cc As FieldFor Each cc In ActiveDocument.FieldsIf cc.Type = wdFieldHyperlink Thencc.UnlinkEnd IfNextSet cc = Nothing'删(微博)[微博]With Selection.Find.Text = "[\[\（\(]微博[\）\]\)]".Replacement.Text = "".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删(博客,微博)With Selection.Find.Text = "(博客,微博)".Replacement.Text = "^p^p".Forward = True.Wrap = wdFindContinue.MatchByte = True.MatchWildcards = FalseEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删象屿期货的段前符号With Selection.Find.Text = ChrW(61548).Replacement.Text = "".Forward = True.Wrap = wdFindContinue.MatchByte = True.MatchWildcards = FalseEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删小标题后的/With Selection.Find.Text = "/^p".Replacement.Text = "^p".Forward = True.Wrap = wdFindContinue.MatchByte = True.MatchWildcards = FalseEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删股票代码With Selection.Find.Text = "\([\-0-9.]{1,}[,^s]{1,}[\-0-9.]{1,}[,^s]{1,}[\-0-9.%]{1,}\)".Replacement.Text = "".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删股票涨跌值With Selection.Find.Text = "\[[\-0-9.%]{1,}\]".Replacement.Text = "".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删[2.98% 资金 研报]With Selection.Find.Text = "\[[\-0-9.%]{1,}^s资金^s研报\]".Replacement.Text = "".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'删(600648,股吧)With Selection.Find.Text = "\([0-9]{6},[股吧基金]{2,3}\)".Replacement.Text = "".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'手动换行符替换成回车符With Selection.Find.Text = "^l".Replacement.Text = "^p".Forward = True.Wrap = wdFindContinue.MatchByte = True.MatchWildcards = FalseEnd WithSelection.Find.Execute Replace:=wdReplaceAll'段与段顶多只隔一行，将任意个回车符号替换成二个With Selection.Find.Text = "(^13)@".Replacement.Text = "^p^p".Forward = True.Wrap = wdFindContinue.MatchByte = False.MatchWildcards = TrueEnd WithSelection.Find.Execute Replace:=wdReplaceAll'全选+剪切Selection.WholeStorySelection.Cut
End Sub

9.Excel双击则复制单元格内容到剪切板

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}").SetText Target.PutInClipboardEnd With
End Sub

10.用对话框打开Excel文件

iFileName = Application.GetOpenFilename("Excel文件 (*.xlsx;*.xls), *.xlsx;*.xls")

11.Excel按指定列升序排列

With wbf.Sort.SortFields.Clear.SortFields.Add Key:=Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending 'descending，递减。Ascending，递增.SetRange Range("A1").CurrentRegion '排序区域.Header = xlGuess '第一行包含标题.MatchCase = False '不区分大小写.Orientation = xlTopToBottom.SortMethod = xlPinYin.Apply
End With

12.汉字编码成URL用的字符串

Public Function Escape(ByVal strText As String) As StringSet JS = CreateObject("msscriptcontrol.scriptcontrol")JS.Language = "JavaScript"Escape = JS.eval_r("encodeURI('" & Replace(strText, "'", "\'") & "');")
End Function

Sub HzWb()Dim bt As Range, r As Long, c As Longr = 1    '1 是表头的行数c = 8    '8 是表头的列数Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents    ' 清除汇总表中原表数据Application.ScreenUpdating = FalseDim FileName As String, wb As Workbook, Erow As Long, fn As String, arr As VariantFileName = Dir(ThisWorkbook.Path & "\*.xls") '返回一个Excel文件，可匹配到.xlsxDo While FileName <> ""If FileName <> ThisWorkbook.Name Then    ' 判断文件是否是本工作簿Erow = Range("A1").CurrentRegion.Rows.Count + 1    ' 取得汇总表中第一条空行行号fn = ThisWorkbook.Path & "\" & FileNameSet wb = GetObject(fn)    ' 将fn 代表的工作簿对象赋给变量Set sht = wb.Worksheets(1)    ' 汇总的是第1 张工作表' 将数据表中的记录保存在arr 数组里arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))' 将数组arr 中的数据写入工作表Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arrwb.Close FalseEnd IfFileName = Dir    ' 用Dir 函数取得其他文件名，并赋给变量LoopApplication.ScreenUpdating = True
End Sub

14.Excel 将指定 数据另存为txt文件

'新建一张表用于存放待保存的数据
Set wbTmp = ThisWorkbook.Worksheets.Add(after:=wb)'复制待保存的数据
wb.Cells(2 + iJx, "C").Resize(iSc, 1).Copy wbTmp.Cells(1, 1)
wb.Cells(2 + iJx, "R").Resize(iSc, 1).Copy wbTmp.Cells(1, 2)'将新表复制出来成为一个单独的文件并另存为txt
wbTmp.Copy
ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\自定义文件名.txt", FileFormat:=xlText, CreateBackup:=False'关闭上一步出现的新Workbook
ActiveWorkbook.Close False'删除原文件中的临时表
wbTmp.Delete