没有合适的资源?快使用搜索试试~ 我知道了~
VBA常用代码[参考].pdf
1.该资源内容由用户上传,如若侵权请联系客服进行举报
2.虚拟产品一经售出概不退款(资源遇到问题,请及时私信上传者)
2.虚拟产品一经售出概不退款(资源遇到问题,请及时私信上传者)
版权申诉
0 下载量 161 浏览量
2021-10-12
01:13:25
上传
评论
收藏 29KB PDF 举报
温馨提示
试读
22页
VBA常用代码[参考].pdf
资源推荐
资源详情
资源评论
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(myDoc.Name, InStrRev(myDoc.Name, ".") - 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", "http://develop.100ppi.com/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)
剩余21页未读,继续阅读
资源评论
czq131452007
- 粉丝: 2
- 资源: 12万+
下载权益
C知道特权
VIP文章
课程特权
开通VIP
上传资源 快速赚钱
- 我的内容管理 展开
- 我的资源 快来上传第一个资源
- 我的收益 登录查看自己的收益
- 我的积分 登录查看自己的积分
- 我的C币 登录后查看C币余额
- 我的收藏
- 我的下载
- 下载帮助
安全验证
文档复制为VIP权益,开通VIP直接复制
信息提交成功