Sub 目录下doc转txt()'目录下所有word文档转为txt,并删除word文档'保存在原目录 '遍历所有文件夹,把带路径的文件名存入字典 On Error Resume Next Dim 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 = Nothing Set objshell = Nothing '创建字典用于存储路径和文件名 Dim DicPath, DicFile, i As Integer, Ke, ContentName As String, FileName As String, MsgTxt Set DicPath = CreateObject('Scripting.Dictionary') Set DicFile = CreateObject('Scripting.Dictionary') DicPath.Add Path, '' i = 0 '存所有路径 Do While i < DicPath.count Ke = DicPath.keys ContentName = Dir(Ke(i), vbDirectory) Do While ContentName <> '' '若有子文件夹,则添加 '跳过当前的目录及上层目录 If ContentName <> '.' And ContentName <> '..' Then If GetAttr(Ke(i) & ContentName) = vbDirectory Then DicPath.Add (Ke(i) & ContentName & '\'), '' End If End If ContentName = Dir Loop i = i + 1 Loop '存所有doc文件名 For Each Ke In DicPath.keys FileName = Dir(Ke & '*.doc') Do While FileName <> '' DicFile.Add (Ke & FileName), '' FileName = Dir Loop Next Ke '打开文件 Application.DisplayAlerts = wdAlertsNone Dim myDoc For Each Ke In DicFile.keys Set myDoc = Documents.Open(Ke) '原路径另存为TXT ActiveDocument.SaveAs2 FileName:=myDoc.Path & '\' & Left(myDoc.Name, InStrRev(myDoc.Name, '.') - 1) & '.txt', FileFormat:=wdFormatText '处理完成后关闭并删除原word文档 ActiveDocument.Close Kill Ke Next Ke MsgBox 'Done!'End Sub
Dim i As Integer, j As Integer, k As Integer 'i用于遍历,j用于计数须合并的行数,k用于填充颜色i = 1k = 0With wbTmp Do While .Cells(i + 1, 1) <> '' j = 1 Do While .Cells(i, 1) = .Cells(i + j, 1) j = j + 1 Loop If j > 1 Then .Range(.Cells(i, 1), .Cells(i + j - 1, 1)).Merge End If If (k Mod 2 = 1) Then .Cells(i, 1).Resize(j, 5).Interior.Color = 5296274 Else: .Cells(i, 1).Resize(j, 5).Interior.Color = 49407 End If k = k + 1 i = i + j LoopEnd With
Sub 替换昨今去()Dim Yesterday_Day As Integer, Yesterday As String, Yesterday_Month As Integer, Yesterday_Year As IntegerDim Today_Day As Integer, Today_Month As Integer, Today_Year As IntegerYesterday = 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.ClearFormatting Selection.Find.Replacement.ClearFormatting '取消所有超链接 Dim cc As Field For Each cc In ActiveDocument.Fields If cc.Type = wdFieldHyperlink Then cc.Unlink End If Next Set cc = Nothing '替换昨天、昨日 With Selection.Find .Text = '昨[天日]{1}' .Replacement.Text = Yesterday_Month & '月' & Yesterday_Day & '日' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '替换今天、今日 With Selection.Find .Text = '今[天日]{1}' .Replacement.Text = Today_Month & '月' & Today_Day & '日' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '替换今年 With Selection.Find .Text = '今年' .Replacement.Text = Today_Year & '年' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '替换去年 With Selection.Find .Text = '去年' .Replacement.Text = Today_Year - 1 & '年' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '删象屿期货的段前符号 With Selection.Find .Text = ChrW(61548) .Replacement.Text = '' .Forward = True .Wrap = wdFindContinue .MatchByte = True .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAll '手动换行符替换成回车符 With Selection.Find .Text = '^l' .Replacement.Text = '^p' .Forward = True .Wrap = wdFindContinue .MatchByte = True .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAll '段与段顶多只隔一行,将任意个回车符号替换成二个 With Selection.Find .Text = '(^13)@' .Replacement.Text = '^p^p' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '全选+剪切 Selection.WholeStory Selection.CutEnd Sub
Sub 新闻排版()'' '选择性粘贴 Selection.PasteAndFormat (wdPasteDefault) Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting '删图片 Dim oInlineShape As InlineShape For Each oInlineShape In ActiveDocument.InlineShapes oInlineShape.Delete Next '取消所有超链接 Dim cc As Field For Each cc In ActiveDocument.Fields If cc.Type = wdFieldHyperlink Then cc.Unlink End If Next Set cc = Nothing '删(微博)[微博] With Selection.Find .Text = '[\[\(\(]微博[\)\]\)]' .Replacement.Text = '' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '删(博客,微博) With Selection.Find .Text = '(博客,微博)' .Replacement.Text = '^p^p' .Forward = True .Wrap = wdFindContinue .MatchByte = True .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAll '删象屿期货的段前符号 With Selection.Find .Text = ChrW(61548) .Replacement.Text = '' .Forward = True .Wrap = wdFindContinue .MatchByte = True .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAll '删小标题后的/ With Selection.Find .Text = '/^p' .Replacement.Text = '^p' .Forward = True .Wrap = wdFindContinue .MatchByte = True .MatchWildcards = False End With Selection.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 = True End With Selection.Find.Execute Replace:=wdReplaceAll '删股票涨跌值 With Selection.Find .Text = '\[[\-0-9.%]{1,}\]' .Replacement.Text = '' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '删[2.98% 资金 研报] With Selection.Find .Text = '\[[\-0-9.%]{1,}^s资金^s研报\]' .Replacement.Text = '' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '删(600648,股吧) With Selection.Find .Text = '\([0-9]{6},[股吧基金]{2,3}\)' .Replacement.Text = '' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '手动换行符替换成回车符 With Selection.Find .Text = '^l' .Replacement.Text = '^p' .Forward = True .Wrap = wdFindContinue .MatchByte = True .MatchWildcards = False End With Selection.Find.Execute Replace:=wdReplaceAll '段与段顶多只隔一行,将任意个回车符号替换成二个 With Selection.Find .Text = '(^13)@' .Replacement.Text = '^p^p' .Forward = True .Wrap = wdFindContinue .MatchByte = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll '全选+剪切 Selection.WholeStory Selection.CutEnd Sub
iFileName = Application.GetOpenFilename('Excel文件 (*.xlsx;*.xls), *.xlsx;*.xls')
Public Function Escape(ByVal strText As String) As String Set JS = CreateObject('msscriptcontrol.scriptcontrol') JS.Language = 'JavaScript' Escape = JS.eval_r('encodeURI('' & Replace(strText, ''', '\'') & '');')End Function
'新建一张表用于存放待保存的数据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)'将新表复制出来成为一个单独的文件并另存为txtwbTmp.CopyActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & '\自定义文件名.txt', FileFormat:=xlText, CreateBackup:=False'关闭上一步出现的新WorkbookActiveWorkbook.Close False'删除原文件中的临时表wbTmp.Delete
版权声明:本文为博主原创文章,未经博主允许不得转载。
联系客服