循环遍历文件夹及子文件夹（宏）2020-8-9（定稿）

tangqingfu · 发表于 2020-8-12 09:07

谢谢各位大佬分享，收藏备用！

413191246se · 发表于 2020-9-1 16:27

No. NAME TEST-TIME CODE-LINES
1 duquancai 81.71秒 27行
2 gbgbxgb 82.54秒 27行
3 Harvda 82.82秒 28行
4 xiaohualu 83.17秒 28行
5 FileSearch 83.33秒 22行
6 cuanju 83.93秒 42行
天！经过测试，5位老师（其中一位是外国人，挪威人Harvda，比我厉害，也是老师）编码的for Word2007-2019循环遍历文件夹及子文件夹的宏，竟然全部适用于Word2003！
再加上Word2003本身也有一个FileSearch方法，同样也管事（但有时我觉得不管事似的）。

wdpfox · 发表于 2020-12-9 14:28

本帖最后由 wdpfox 于 2020-12-11 16:27 编辑

已解决。

xnhwzs123 · 发表于 2024-1-7 11:54

大侠，总是显示 If GetAttr(FolderName & strFileName) And vbDirectory Then出错，是什么原因

xnhwzs123 · 发表于 2024-1-7 12:11

可否将WORD排版前格式，运行宏后的格式，分别上传并说明一下

413191246se · 发表于 2024-1-8 03:11

* 楼上朋友：下面附上 3 位老师的代码，请注意，对于单个文档来说，是已经打开和自动保存的，你只需要处理一下单个文档的格式（我这里是设置为红色，要对 DocProcess 处理一下）即可。哪位老师的代码都可以用，因为我都测试过，请将下面的代码复制到空白文档后，再剪切到 VBE 中，再按 Alt + F8 找到3 位老师的谁的代码均可执行之。

Sub LoopFolder_duquancai()
'循环遍历文件夹及子文件夹
Dim pPath$, f As Object, fd As Object, fso As Object, Stack$(), top&, n&, stxt$, doc As Document, x&
pPath = SelectFolder
Set fso = CreateObject("Scripting.FileSystemObject")
top = 1
ReDim Stack(0 To top)
Do While top >= 1
For Each f In fso.getFolder(pPath).Files
n = n + 1
stxt = f.Path
If stxt Like "*.doc*" Then
Set doc = Documents.Open(FileName:=stxt)
DocProcess '单个文档处理
doc.Close SaveChanges:=wdSaveChanges
x = x + 1
End If
Next
For Each fd In fso.getFolder(pPath).subFolders
Stack(top) = fd.Path
top = top + 1
If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
Next
If top > 0 Then pPath = Stack(top - 1): top = top - 1
Loop
Set f = Nothing
Set fd = Nothing
Set fso = Nothing
MsgBox "处理完毕！共 " & n & " 个文档！Word 文档 " & x & " 个！", 0 + 48
End Sub
Sub LoopFolder_gbgbxgb()
'循环遍历文件夹及子文件夹
Dim d As Object, thePath$, theStr$, i&, j&, k&, doc As Document
thePath = SelectFolder
Set d = CreateObject("Scripting.Dictionary")
d(thePath) = ""
Do While i < d.Count
thePath = d.keys()(i)
theStr = Dir(thePath, vbDirectory)
Do While theStr <> ""
If theStr <> "." And theStr <> ".." Then
If (GetAttr(thePath & theStr) And vbDirectory) = vbDirectory Then
d(thePath & theStr & "") = ""
Else
j = j + 1
If thePath & theStr Like "*.doc*" Then
Set doc = Documents.Open(FileName:=thePath & theStr)
DocProcess '单个文档处理
doc.Close SaveChanges:=wdSaveChanges
k = k + 1
End If
End If
End If
theStr = Dir
Loop
i = i + 1
Loop
Set d = Nothing
MsgBox "处理完毕！共 " & j & " 个文档！Word 文档 " & k & " 个！", 0 + 48
End Sub
Sub LoopFolder_xiaohualu()
'循环遍历文件夹及子文件夹
Dim d, n&, m&, x&, mydir, dk, doc As Document, i&
Set d = CreateObject("Scripting.Dictionary")
d(SelectFolder) = ""
Do While n < d.Count
dk = d.keys
mydir = Dir(dk(n), vbDirectory)
Do While mydir <> ""
If mydir <> "." And mydir <> ".." Then
If GetAttr(dk(n) & mydir) = vbDirectory Then
d(dk(n) & mydir & "") = ""
m = m + 1
Else
x = x + 1
If dk(n) & mydir Like "*.doc*" Then
Set doc = Documents.Open(FileName:=dk(n) & mydir)
DocProcess '单个文档处理
doc.Close SaveChanges:=wdSaveChanges
i = i + 1
End If
End If
End If
mydir = Dir
Loop
n = n + 1
Loop
Set d = Nothing
Set dk = Nothing
MsgBox "处理完毕！共 " & x & " 个文档！Word 文档 " & i & " 个！", 0 + 48
End Sub
Function SelectFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then SelectFolder = .SelectedItems(1) & "" Else End
End With
If MsgBox("是否选择文件夹 """ & SelectFolder & """ ?", 4 + 16) = vbNo Then End
End Function
Sub DocProcess()
ActiveDocument.Content.Font.Color = wdColorRed
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[分享] 循环遍历文件夹及子文件夹（宏）2020-8-9（定稿）