求教，如何对一个文件夹下还有子文件夹内的word文档执行同一个宏

yr9908

自己录制一一段宏，修改页眉页脚
现在在一个文件夹里有十来个小文件夹，每个小文件夹里有六七个个word文档，现在要改成相同格式的页眉页脚
office 2010版本的

求教！

duquancai

用遍历所有文件夹中的文件，但是你没有提供主文件夹路径，不会是遍历整个磁盘吧？呵呵！还有具体怎么修改页眉页脚？最好上传附件以便测试。请测试以下代码：

Sub 遍历所有文件夹中的文件()
  Dim arr(1 To 100000) As String, i&, k&, x&, f$, f1$, oDoc As Document
  Dim Osec As Section, Ohefo As HeaderFooter
  Application.ScreenUpdating = False
  arr(1) = "D:\这里输入文件夹路径\" '这里输入文件夹路径
  i = 1: k = 1
  Do While i < UBound(arr)
    If arr(i) = "" Then Exit Do
    f = Dir(arr(i), vbDirectory)
    Do
      If InStr(f, ".") = 0 And f <> "" Then
        k = k + 1
        arr(k) = arr(i) & f & "\"
      End If
      f = Dir
    Loop Until f = ""
    i = i + 1
  Loop
  For x = 1 To UBound(arr)
      If arr(x) = "" Then Exit For
       f1 = Dir(arr(x) & "*.doc*")
     Do While f1 <> ""
       Set oDoc = Documents.Open(arr(x) & f1, Visible:=False)
        For Each Osec In oDoc.Sections
          For Each Ohefo In Osec.Headers
              Ohefo.Range.InsertAfter "添加页眉文字" '这里输入需要添加的字符
          Next
       Next
       oDoc.Close True
       Set oDoc = Nothing
       f1 = Dir
     Loop
  Next x
  Application.ScreenUpdating = True
End Sub

yr9908

duquancai 发表于 2016-7-10 10:09
用遍历所有文件夹中的文件，但是你没有提供主文件夹路径，不会是遍历整个磁盘吧？呵呵！还有具体怎么修改页 ...

修改页眉页脚能够直接调用sub函数吗  因为是录制的 调的东西挺多的，还有一个主文件夹的路径能不能改成弹窗选取
昨天找了好多代码 都没能实现

duquancai

yr9908 发表于 2016-7-10 11:43
修改页眉页脚能够直接调用sub函数吗  因为是录制的 调的东西挺多的，还有一个主文件夹的路径能不能改成弹 ...

你自己根据需要修改这个代码吧！

duquancai

yr9908 发表于 2016-7-10 11:43
修改页眉页脚能够直接调用sub函数吗  因为是录制的 调的东西挺多的，还有一个主文件夹的路径能不能改成弹 ...

Sub 遍历所有文件夹中的文件()
  Dim arr(1 To 100000) As String, i&, k&, x&, f$, f1$, oDoc As Document
  Dim Osec As Section, Ohefo As HeaderFooter
  Application.ScreenUpdating = False
  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = False Then Exit Sub
    arr(1) = .SelectedItems(1) & "\"
  End With
  i = 1: k = 1
  Do While i < UBound(arr)
    If arr(i) = "" Then Exit Do
    f = Dir(arr(i), vbDirectory)
    Do
      If InStr(f, ".") = 0 And f <> "" Then
        k = k + 1
        arr(k) = arr(i) & f & "\"
      End If
      f = Dir
    Loop Until f = ""
    i = i + 1
  Loop
  For x = 1 To UBound(arr)
      If arr(x) = "" Then Exit For
       f1 = Dir(arr(x) & "*.doc*")
     Do While f1 <> ""
       Set oDoc = Documents.Open(arr(x) & f1, Visible:=False)
        For Each Osec In oDoc.Sections
          For Each Ohefo In Osec.Headers
              Ohefo.Range.InsertAfter "添加页眉文字" '这里输入需要添加的字符
          Next
       Next
       oDoc.Close True
       Set oDoc = Nothing
       f1 = Dir
     Loop
  Next x
  Application.ScreenUpdating = True
End Sub

yr9908

duquancai 发表于 2016-7-10 15:30
Sub 遍历所有文件夹中的文件()
  Dim arr(1 To 100000) As String, i&, k&, x&, f$, f1$, oDoc As Docum ...

谢谢啊，自己改了改 可以用 没什么毛病  后面自己再优化优化

xxcza

有个软件叫word批量处理大师