VBA如何遍历所有文件夹中word

jiangxsliu

本人最近在进行大量的word替换，在论坛大佬的帮助下，已经把替换文件写好了，现在个人有个小疑问，以下的代码只能做到替换特定文件夹下的word,并不能替换其子文件夹，如想遍历，请问应该如何修改呢？我想过用通配符的形式定义fpath,但好像不成功，麻烦大佬看下。
Sub wordReplace() '正文内容替换
Application.Visible = False
Dim fpath As String, fname As String, doc As Document
fpath = "F:\test\" '文件路径
fname = Dir(fpath & "*.doc?")
Do While fname <> ""
Set doc = Documents.Open(fpath & fname)
With doc
With Selection.Find
.ClearFormatting
    .Text = "环境监测中心站"
    .Replacement.ClearFormatting
    .Replacement.Text = "生态环境监测站"
    .Execute Replace:=wdReplaceAll
End With
.Save
.Close
End With
fname = Dir
Loop
Application.Visible = True
End Sub

3190496160

遍历多级文件夹的帖子论坛很多的，自己搜搜看看呗，没有附件，只能这么说

zhanglei1371

1. Function 栈遍历(pPath As String, pMask As String, pSub As Boolean)
   
2.         'fileNameArr装文件名动态数组，psb子目录开关,pPath搜索起始路径，pMask扩展名(如doc)
   
3.         On Error Resume Next
   
4.         Dim fileNameArr() As String, DirFile, mf&, pPath1$
   
5.        Dim workStack$(), top&    'workstack工作栈,top栈顶变量
   
6.     pPath = Trim(pPath)
   
7.     If Right(pPath, 1) <> "" Then pPath = pPath & ""    ' 对搜索路径加 backslash（反斜线）
   
8.     pPath1 = pPath
   
9.     top = 1
   
10.     ReDim Preserve workStack(0 To top)
    
11.     Do While top >= 1
    
12.         DirFile = Dir(pPath1 & "*." & pMask)
    
13.         Do While DirFile <> ""
    
14.             mf = mf + 1
    
15.             ReDim Preserve fileNameArr(1 To mf)
    
16.             fileNameArr(mf) = pPath1 & DirFile
    
17.             DirFile = Dir
    
18.         Loop
    
19.         If pSub = False Then Exit Function
    
20.         DirFile = Dir(pPath1, vbDirectory)    ' 搜索子目录
    
21.         Do While DirFile <> ""
    
22.             If DirFile <> "." And DirFile <> ".." Then
    
23.                 If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
    
24.                     workStack(top) = pPath1 & DirFile & ""    '压栈
    
25.                     top = top + 1
    
26.                     If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
    
27.                 End If
    
28.             End If
    
29.             DirFile = Dir    'next file
    
30.         Loop
    
31.         If top > 0 Then pPath1 = workStack(top - 1): top = top - 1    '弹栈
    
32.     Loop
    
33.         栈遍历 = fileNameArr
    
34.     End Function
    

复制代码

使用：
sub test()
arr=("C:\文档保存", "doc", True)
for each fname in arr
    这里放循环处理代码就可以了。
next
end sub

jiangxsliu

zhanglei1371 发表于 2021-6-22 20:57
使用：
sub test()
arr=("C:\文档保存", "doc", True)

不好意思，因为我刚接触vba没多久，请问function是要放在哪里的呢？我直接在通用里编辑了后把两段都放上去了，在修改第二段后运行，提示“arr=("C:\文档保存", "doc", True)”编译错误，语法错误。

zhanglei1371

jiangxsliu 发表于 2021-6-23 10:02
不好意思，因为我刚接触vba没多久，请问function是要放在哪里的呢？我直接在通用里编辑了后把两段都放上 ...

搞错了，是这样：
使用：
sub test()
arr=栈遍历("F:\test\", "doc", True)
for each fname in arr
    这里放循环处理代码就可以了。
next
end sub

jiangxsliu

zhanglei1371 发表于 2021-6-23 12:03
搞错了，是这样：
使用：
sub test()

运行提示"arrarr = 杖遍历("F:\test", "doc?", True)中，arr参数不可选“，顺便麻烦您看下我这样写可以么？
Sub wordReplace5() '正文内容替换
Dim doc As Document
arr = 杖遍历("F:\test", "doc?", True)
For Each fname In arr
  Set doc = Documents.Open(fpath & fname)
With doc
With Selection.Find
.ClearFormatting
    .Text = "东莞市环境监测中心站"
    .Replacement.ClearFormatting
    .Replacement.Text = "广东省东莞生态环境监测站"
    .Execute Replace:=wdReplaceAll
End With
.Save
.Close
End With
Application.Visible = True
Next
End Sub

jiangxsliu

zhanglei1371 发表于 2021-6-23 12:03
搞错了，是这样：
使用：
sub test()

多谢大佬，我查了你以前在其他帖子的回复，借用了你的代码，完成了遍历工作。

liufei2081

zhanglei1371 发表于 2021-6-23 12:03
搞错了，是这样：
使用：
sub test()

提示For循环未初始化，这个怎么改
Sub test()

Dim arr() As String
arr = 栈遍历("F:\test\", "doc", True)
For Each FName In arr
    '这里放循环处理代码就可以了?

Next FName

End Sub
这样不能遍历到子文件夹的文件夹啊

liufei2081

测试中测试中测试中

同心/ty

能提供最后的测试成功的代码吗？