自己写的实用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 = 1 k = 0 With 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 Loop End With
5.若同目录下不存在某文件夹,则创建
Dim sr sr = 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 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.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.Cut End 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 False Application.ScreenUpdating = True MsgBox "已完成!" 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.Cut End 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 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 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 = 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
版权声明:本文为博主原创文章,未经博主允许不得转载。