自己写的实用VBA代码合集√
1.遍历所有已打开的word文档
For Each docOpened In Documents
……
Next docOpened2.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 Sub3.获取网页源代码
有时源代码里的中文会变成乱码，此时用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 With5.若同目录下不存在某文件夹，则创建
Dim sr
sr = Dir(ThisWorkbook.Path & "\上海办待导入txt", vbDirectory)
If sr = "" Then
MkDir ThisWorkbook.Path & "\上海办待导入txt"
End If6.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 Sub7.提取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 Sub8.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 Sub9.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 With12.汉字编码成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 Function13.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") '返回一个Excel文件，可匹配到.xlsx
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