Create a vba code to replace all the headers, of all the word documents in a Folder and Subfolders

Question

Sub ReplaceEntireHdr() 
    Dim wrd As Word.Application 
    Set wrd = CreateObject("word.application") 
    wrd.Visible = True 
    AppActivate wrd.Name 
     'Change the directory to YOUR folder's path
    fName = Dir("C:\Users\user1\Desktop\A\*.doc") 
    Do While (fName <> "") 
        With wrd 
             'Change the directory to YOUR folder's path
            .Documents.Open ("C:\Users\user1\Desktop\A\" & fName) 
            If .ActiveWindow.View.SplitSpecial = wdPaneNone Then 
                .ActiveWindow.ActivePane.View.Type = wdPrintView 
            Else 
                .ActiveWindow.View.Type = wdPrintView 
            End If 
            .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader 
            .Selection.WholeStory 
            .Selection.Paste 
            .ActiveDocument.Save 
            .ActiveDocument.Close 
        End With 
        fName = Dir 
    Loop 
    Set wrd = Nothing 
End Sub

I use this vba code to replace all the headers, of all the word documents in a folder 'A'. However if there is any subfolder in the parent folder 'A' with word documents, the vba code skips those documents. Could anyone please tell me how to include the word documents in the subfolders as well? Perhaps by making some changes in the code or any other vba code which can do the same job. Thanks in advance.

Answer 1

In order to pick up the folders (directories) you need to specify the vbDirectory attribute. By default, Dir only "sees" things that match vbNormal.

Here's an example that picks up both files and sub-directories. The GetAttr function checks whether the file attribute is vbDirectory. If it's not, then it's a file.

What you can do is save the directory paths in an array, then loop that to get the files in the sub-directories.

Sub GetFilesandSubDir()
  Dim sPath As String, sPattern As String
  Dim sSearch As String, sFile As String
  Dim sPathSub As String, sSearchSub As String
  Dim aSubDirs As Variant, i As Long

  sPattern = "*.*"
  sPath = "C:\Test\"
  sSearch = sPath & sPattern
  sFile = Dir(sPath, vbNormal + vbDirectory)
  aSubDirs = TestDirWithSubFolders(sPath, sPattern, sSearch, sFile)
  For i = LBound(aSubDirs) To UBound(aSubDirs)
    Debug.Print "Directory: " & aSubDirs(i)
    sPathSub = sPath & aSubDirs(i) & "\"
    sSearchSub = sPathSub & sPattern
    sFile = Dir(sPathSub, vbNormal + vbDirectory)
    TestDirWithSubFolders sPathSub, sPattern, sSearchSub, sFile
  Next
End Sub

Function TestDirWithSubFolders(sPath As String, sPattern As String, _
      sSearch As String, sFile As String) As Variant
  Dim aSubDirs() As Variant, i As Long

  i = 0
  Do While sFile <> ""
    If GetAttr(sPath & sFile) = vbDirectory Then
        'Debug.Print "Directory: " & sFile
        ReDim Preserve aSubDirs(i)
        aSubDirs(i) = sFile
        i = i + 1
    Else
        Debug.Print "File: " & sFile
    End If
    sFile = Dir
  Loop
  TestDirWithSubFolders = aSubDirs
End Function