Batch change the footer in multiple files with footer from another file

kalagas · #1 02-05-2020, 03:00 PM

Hi to all.
I have many many word files inside a folder and subfolders and i would like to change their footer.

I would like to change/replace the footer to all these files with the footer i use in a specific word file (let's say this specific word file is my guide).

So I was wondering if there is a macro to choose the folder i want and then change the footer in all word documents at once (in that folder and it's subfolders).

i know how to use custom process from Document Batch Processes, so if there is a macro for Document Batch Processes it would be great.

Thanks in advance for your time and help.

macropod · #2 02-05-2020, 09:18 PM

Try running the following macro from the document containing the footer you want to replicate:

Code:

Option Explicit
Dim FSO As Object, oFolder As Object, StrFldrs As String
Dim DocSrc As Document, DocTgt As Document, Rng As Range
Dim StrPth As String, StrNm As String, StrSrc As String
 
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder: If TopLevelFolder = "" Then Exit Sub
Set DocSrc = ActiveDocument: StrSrc = DocSrc.FullName
Set Rng = DocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range
StrFldrs = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFldrs, vbCr))
  Call UpdateDocuments(CStr(Split(StrFldrs, vbCr)(i)))
Next
Set Rng = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Set TheFolders = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

Sub UpdateDocuments(StrPth As String)
StrNm = Dir(StrPth & "\*.doc", vbNormal)
While StrNm <> ""
  If StrPth & "\" & StrNm <> StrSrc Then
    Set DocTgt = Documents.Open(FileName:=StrPth & "\" & StrNm, AddToRecentFiles:=False, Visible:=False)
    With DocTgt
      With .Sections.First.Footers(wdHeaderFooterPrimary).Range
        .FormattedText = Rng.FormattedText
        .Characters.Last.Text = vbNullString
      End With
      .Close True
    End With
  End If
  StrNm = Dir()
Wend
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFldrs = StrFldrs & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub

For PC macro installation & usage instructions, see: Installing Macros

iqsoft · #3 09-17-2024, 08:58 AM

How to do it for both header and footer?

macropod · #4 09-17-2024, 03:38 PM

A few trivial changes:

Code:

Option Explicit
Dim FSO As Object, oFolder As Object, StrFldrs As String
Dim DocSrc As Document, DocTgt As Document, RngHd As Range, RngFt As Range
Dim StrPth As String, StrNm As String, StrSrc As String
 
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder: If TopLevelFolder = "" Then Exit Sub
Set DocSrc = ActiveDocument: StrSrc = DocSrc.FullName
Set RngHd = DocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range
Set RngFt = DocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range
StrFldrs = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFldrs, vbCr))
  Call UpdateDocuments(CStr(Split(StrFldrs, vbCr)(i)))
Next
Set RngHd = Nothing: Set RngFt = Nothing: Set DocTgt = Nothing: Set DocSrc = Nothing
Set TheFolders = Nothing: Set FSO = Nothing
Application.ScreenUpdating = True
End Sub

Sub UpdateDocuments(StrPth As String)
StrNm = Dir(StrPth & "\*.doc", vbNormal)
While StrNm <> ""
  If StrPth & "\" & StrNm <> StrSrc Then
    Set DocTgt = Documents.Open(FileName:=StrPth & "\" & StrNm, AddToRecentFiles:=False, Visible:=False)
    With DocTgt
      With .Sections.First.Headers(wdHeaderFooterPrimary).Range
        .FormattedText = RngHd.FormattedText
        .Characters.Last.Text = vbNullString
      End With
      With .Sections.First.Footers(wdHeaderFooterPrimary).Range
        .FormattedText = RngFt.FormattedText
        .Characters.Last.Text = vbNullString
      End With
      .Close True
    End With
  End If
  StrNm = Dir()
Wend
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFldrs = StrFldrs & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub

mjjohnson · #5 12-10-2024, 03:02 PM

Mr. Macropod, would you kindly provide an edit of the macro that updates only the header? I tried the footer code and it works perfectly, but I need the header to be updated instead.

Thanks in advance!

macropod · #6 12-10-2024, 03:45 PM

All you need do is delete:

Code:

Set RngFt = DocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range

and:

Code:

      With .Sections.First.Footers(wdHeaderFooterPrimary).Range
        .FormattedText = RngFt.FormattedText
        .Characters.Last.Text = vbNullString
      End With

Frankie4life · #7 06-12-2025, 02:53 PM

I am using this macro but some of the documents seem to change the font on the header and footer rather than except the font of the active document. Any ideas what could be causing this?

macropod · #8 06-12-2025, 03:23 PM

Probably because the documents being processed have the 'Automatically update document styles' attribute set.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Batch replace Header and Footer and QuickStyle	Artmax	Word VBA	14	01-11-2024 05:36 PM
Batch change the font style in multiple word files inside folder and subfolders	kalagas	Word VBA	11	10-05-2023 05:13 AM
Batch applying a macro to remove Header and Footer using Batch Auto Addin	Edszx	Word VBA	2	05-27-2019 11:16 PM
I have 20 page word document with a footer. Can i change page # 10 footer only?	aligahk06	Word	2	10-25-2017 04:53 AM
Word Macro - change date in footer for all files in a folder	patidallas22	Word VBA	2	03-09-2012 08:14 AM