自己写的实用VBA代码合集
1.遍历所有已打开的word文档
For Each docOpened In Documents ……Next docOpened
2.Word 将目录下所有文档转换为txt，并删除原文档
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
3.获取网页源代码
有时源代码里的中文会变成乱码，此时用StrConv函数转换成unicode，问题即可解决
Dim httpRequest As Object Set 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, False httpRequest.Send txtTemp = httpRequest.responseText 或txtTemp = StrConv(httpRequest.responsebody, vbUnicode)
4.Excel合并相同文件名的单元格，不同文件名的行填充不同的背景色
A列填了文件名，已排序。
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
5.若同目录下不存在某文件夹，则创建
Dim srsr = Dir(ThisWorkbook.Path & '\上海办待导入txt', vbDirectory)If sr = '' Then MkDir ThisWorkbook.Path & '\上海办待导入txt'End If
6.Word替换昨日今日去年之类的字眼
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
7.提取word文档里的图片
Sub 存成html()Application.ScreenUpdating = False Dim FileName As String FileName = InputBox('请输入文件名') Selection.Copy Documents.Add DocumentType:=wdNewBlankDocument Selection.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:= _ False ActiveWindow.View.Type = wdWebView '段与段顶多只隔一行，将任意个回车符号替换成二个 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.Cut ActiveDocument.Close FalseApplication.ScreenUpdating = TrueMsgBox '已完成！'End Sub
8.Word 删除新闻中的多余代码和文字
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
9.Excel双击则复制单元格内容到剪切板
放到Worksheet对应的代码中
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) With CreateObject('new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}') .SetText Target .PutInClipboard End WithEnd 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 .ApplyEnd With
12.汉字编码成URL用的字符串
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
13.Excel汇总同目录文件
Sub HzWb() Dim bt As Range, r As Long, c As Long r = 1 '1 是表头的行数 c = 8 '8 是表头的列数 Range(Cells(r + 1, 'A'), Cells(65536, c)).ClearContents ' 清除汇总表中原表数据 Application.ScreenUpdating = False Dim FileName As String, wb As Workbook, Erow As Long, fn As String, arr As Variant FileName = Dir(ThisWorkbook.Path & '\*.xls') Do While FileName <> '' If FileName <> ThisWorkbook.Name Then ' 判断文件是否是本工作簿 Erow = Range('A1').CurrentRegion.Rows.Count + 1 ' 取得汇总表中第一条空行行号 fn = ThisWorkbook.Path & '\' & FileName Set 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)) = arr wb.Close False End If FileName = Dir ' 用Dir 函数取得其他文件名，并赋给变量 Loop Application.ScreenUpdating = TrueEnd 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)'将新表复制出来成为一个单独的文件并另存为txtwbTmp.CopyActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & '\自定义文件名.txt', FileFormat:=xlText, CreateBackup:=False'关闭上一步出现的新WorkbookActiveWorkbook.Close False'删除原文件中的临时表wbTmp.Delete
版权声明：本文为博主原创文章，未经博主允许不得转载。
赞 (0)