当前位置：文档之家› VBA常用代码

VBA常用代码

VBA常用代码
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.sel f.Path & "\"

Set objfolder = Nothing

Set objshell = Nothing

'创建字典用于存储路径和文件名

Dim DicPath, DicFile, i As Integer, Ke, ContentName A s 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) & Conte ntName & "\"), ""

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(https://www.doczj.com/doc/924135450.html,, InStrRev(https://www.doczj.com/doc/924135450.html,, ".") - 1) & ".txt", FileFormat:=wdFormatText

'处理完成后关闭并删除原word文档

ActiveDocument.Close

Kill Ke

Next Ke

MsgBox "Done！"

End Sub

3.获取网页源代码

Dim httpRequest As Object

Set httpRequest = CreateObject("MSXML2.XMLHTTP.3.0")

httpRequest.Open "GET", "https://www.doczj.com/doc/924135450.html,/tmp/auto product/ccq2/ci/cha_num.php?pid=" & ItemID & "&sdate=" & sDate & "&edate=" & eDate, False

httpRequest.Send

txtTemp = 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 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_M onth 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, EmbedTrueTypeFont s:=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. "

.Replacement.Text = ""

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删股票涨跌值

With Selection.Find

.Text = "

[\-0?9.

"

.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.

"

.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双击则复制单元格内容到剪切板

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")

https://www.doczj.com/doc/924135450.html,nguage = "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") '返回一个Excel文件，可匹配到.xlsx

Do While FileName <> ""

If FileName <> https://www.doczj.com/doc/924135450.html, Then ' 判断文件是否是本工作簿

Erow = Range("A1").CurrentRegion.Rows.Count + 1 ' 取得汇总表中第一条空行行号

fn = ThisWorkbook.Path & "\" & FileName

Set wb = GetObject(fn) ' 将fn 代表的工作簿对象赋给变量

Set sht = wb.Worksheets(1) ' 汇总的是第1 张工作表

单片机汇编指令大全

单片机汇编指令一览表 作者：乡下人 助记符指令说明字节数周期数 （数据传递类指令） MOV A，Rn 寄存器传送到累加器 1 1 MOV A，direct 直接地址传送到累加器 2 1 MOV A，@Ri 累加器传送到外部RAM(8 地址) 1 1 MOV A，#data 立即数传送到累加器 2 1 MOV Rn，A 累加器传送到寄存器 1 1 MOV Rn，direct 直接地址传送到寄存器 2 2 MOV Rn，#data 累加器传送到直接地址 2 1 MOV direct，Rn 寄存器传送到直接地址 2 1 MOV direct，direct 直接地址传送到直接地址 3 2 MOV direct，A 累加器传送到直接地址 2 1 MOV direct，@Ri 间接RAM 传送到直接地址 2 2 MOV direct，#data 立即数传送到直接地址 3 2 MOV @Ri，A 直接地址传送到直接地址 1 2 MOV @Ri，direct 直接地址传送到间接RAM 2 1 MOV @Ri，#data 立即数传送到间接RAM 2 2 MOV DPTR，#data16 16 位常数加载到数据指针 3 1 MOVC A，@A+DPTR 代码字节传送到累加器 1 2 MOVC A，@A+PC 代码字节传送到累加器 1 2 MOVX A，@Ri 外部RAM(8 地址)传送到累加器 1 2 MOVX A，@DPTR 外部RAM(16 地址)传送到累加器 1 2 MOVX @Ri，A 累加器传送到外部RAM(8 地址) 1 2 MOVX @DPTR，A 累加器传送到外部RAM(16 地址) 1 2 PUSH direct 直接地址压入堆栈 2 2 POP direct 直接地址弹出堆栈 2 2 XCH A,Rn 寄存器和累加器交换 1 1 XCH A, direct 直接地址和累加器交换 2 1 XCH A, @Ri 间接RAM 和累加器交换 1 1 XCHD A, @Ri 间接RAM 和累加器交换低4 位字节 1 1 (算术运算类指令) INC A 累加器加1 1 1 INC Rn 寄存器加1 1 1 INC direct 直接地址加1 2 1 INC @Ri 间接RAM 加1 1 1 INC DPTR 数据指针加1 1 2 DEC A 累加器减1 1 1 DEC Rn 寄存器减1 1 1 DEC direct 直接地址减1 2 2

excelvba常见字典用法集锦及代码详解(全)

常见字典用法集锦及代码详解 前言 凡是上过学校的人都使用过字典，从新华字典、成语词典，到英汉字典以及各种各样数不胜数的专业字典，字典是上学必备的、经常查阅的工具书。有了它们，我们可以很方便的通过查找某个关键字，进而查到这个关键字的种种解释，非常快捷实用。 凡是上过EH论坛的想学习VBA里面字典用法的，几乎都看过研究过northwolves狼版主、oobird版主的有关字典的精华贴和经典代码。我也是从这里接触到和学习到字典的，在此，对他们表示深深的谢意，同时也对很多把字典用得出神入化的高手们致敬，从他们那里我们也学到了很多，也得到了提高。 字典对象只有4个属性和6个方法，相对其它的对象要简洁得多，而且容易理解使用方便，功能强大，运行速度非常快，效率极高。深受大家的喜爱。 本文希望通过对一些字典应用的典型实例的代码的详细解释来

给初次接触字典和想要进一步了解字典用法的朋友提供一点备查的参考资料，希望大家能喜欢。 给代码注释估计是大家都怕做的，因为往往是出力不讨好的，稍不留神或者自己确实理解得不对，还会贻误他人。所以下面的这些注释如果有不对或者不妥当的地方，请大家跟帖时指正批评，及时改正。 字典的简介 字典（Dictionary）对象是微软Windows脚本语言中的一个很有用的对象。 附带提一下，有名的正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject）对象也是微软Windows脚本语言中的一份子。 字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。就好像一本字典书一样，是

网页设计试题及html代码

2.2.3 字型设置标记 功能：设置文字的风格，如黑体、斜体、带下划线等，这是一组标记，它们可以单独使用，也可以混合使用产生复合修饰效果。常用的标记有以下一些： … ：文字以粗体显示。 … ：文字显示为斜体。 … ：显示下划线。 … ：删除线。 … ：使文字大小相对于前面的文字增大一级。 … ：使文字大小相对于前面的文字减小一级。 … ：使文字成为前一个字符的上标。 …：使文字成为前一个字符的下标。 …：使文字显示为闪烁效果。 …：以等宽体显示西文字符。 …：输出引用方式的字体，通常是斜体。 …：强调文字，通常用斜体加黑体。 …：特别强调的文字，通常也是斜体加黑体。 注：有些标记的效果必须在动态环境下才能显示，例如 标记。 【例2-4】字型设置标记的应用。 例如单标记

表示在文档当前位置画一条水平线，一般是从窗口中当前行的最左端一直画到最右端，它可以带这么一些属性：
。 功能：设置网页中普通文字的显示效果。 格式：文字。 格式：标题内容。 属性：n 表示标题字号的级别，可以是1～6之间的任意整数，数字越小，字号越大。 段落标记 功能：设置文章段落的开始和结束。浏览器在解释HTML文档时，会自动忽略文档中的回车、空格以及其他一些符号，所以在文档中输入回车，并不意味着在浏览器内将看到一个不同的段落，当需要在网页中插入新的段落时，可以使用段落标记，它可以将标记后面的内容另起一段。格式：

…

。 强制换行标记 功能：另起一行显示文字。 格式：
插入水平线标记 功能：在页面上画横线，可用于页面上内容的分割。 格式：
1．无序列表 功能：设置无序列表。 格式：
相关文档 最新文档