Adding existing Header and Footer for multiple word documents - vba

Question

I have around 1000 word documents in one folder which the header and footer needs to be added/changed (header need to added/changed just for the first page).
I found a very helpful VBA script which is work but I tried but can not style and format to my needs, which is shown in the attached pictures
Header Style I need
Footer Style I need
The found working code which i found in stackoverflow:
Sub openAllfilesInALocation()
Dim Doc
Dim i As Integer
Dim docToOpen As FileDialog
Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
docToOpen.Show
For i = 1 To docToOpen.SelectedItems.Count
'Open each document
Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
With ActiveDocument.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Header goes here"
.Footers(wdHeaderFooterPrimary).Range.Text = "Footer goes here"
End With
Doc.Save
Doc.Close
Next i
End Sub
Thanks in advance for everybody reading and/or helping me with this question, because if I can not work it out, I need to add for around 1000 word docs headers and footers manually...... :( so thanks for helping or just trying!

Answer 1

Before you write code for this you need to break the task down into steps.
Open one of the documents that you need to apply the changes to.
Record a macro whilst you edit the Header style so that it has the correct formatting
Record a macro whilst you edit the Footer style so that it has the correct formatting
Edit the header of the document to include whatever logo and text you require.
Select the content of the header and save as as a Building Block - on the Header & Footer tab click "Header" then "Save Selection to Header Gallery". Ensure that you pay attention to which template you are saving it to as you will need to know this later.
Edit the footer of the document to include whatever text you require.
Select the content of the footer and save as as a Building Block - on the Header & Footer tab click "Footer" then "Save Selection to Footer Gallery". Again ensure that you pay attention to which template you are saving it to.
Now you can write your code. For example:
Sub openAllfilesInALocation()
Dim Doc As Document
Dim i As Integer
Dim BBlockSource As Template
Set BBlockSource = Application.Templates("<Full path to template you stored building blocks in>")
Dim docToOpen As FileDialog
Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
docToOpen.Show
For i = 1 To docToOpen.SelectedItems.Count
'Open each document
Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
MacroToModifyHeaderStyle 'name of the macros you recorded in steps 2 & 3
MacroToModifyFooterStyle
With ActiveDocument.Sections(1)
BBlockSource.BuildingBlockEntries("Name of Header Building Block").Insert .Headers(wdHeaderFooterFirstPage).Range
BBlockSource.BuildingBlockEntries("Name of Footer Building Block").Insert .Footers(wdHeaderFooterFirstPage).Range
'you may need the following if an extra paragraph is created when adding the building block
'.Headers(wdHeaderFooterFirstPage).Range.Paragraphs.Last.Range.Delete
'.Footers(wdHeaderFooterFirstPage).Range.Paragraphs.Last.Range.Delete
End With
Doc.Save
Doc.Close
Next i
End Sub
Obviously you test your code on a copy of some of the files before attempting to run it on all of them.

Answer 2

Simply add the following macro to a document containing your new header & footer, then run the macro, which includes a folder browser so you can select the folder to process.
Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
Dim Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> wdDocSrc.FullName Then
Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
AddToRecentFiles:=False, Visible:=False)
With wdDocTgt
For Each Sctn In .Sections
'For Headers
For Each HdFt In Sctn.Headers
With HdFt
If .Exists Then
If .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
End If
End If
End With
Next
'For footers
For Each HdFt In Sctn.Footers
With HdFt
If .Exists Then
If .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range.FormattedText
End If
End If
End With
Next
Next
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
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
As coded, the macro assumes the document you're running the macro from has only one Section, with up to three populated headers (as allowed by Word), and that all headers in the target document are to be updated to match the source document's primary header & footer. If you only want to update headers in the first Section, delete the footer loop and delete 'For Each Sctn In .Sections' and it's 'Next' later in the code and change 'For Each HdFt In Sctn.Headers' to 'For Each HdFt In .Sections(1).Headers'.