Colonist010
Colonist010

Reputation: 3

Adding existing Header and Footer for multiple word documents

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 screenshot header style

Footer Style I need screenshot footer style

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!

Upvotes: 0

Views: 2080

Answers (2)

macropod
macropod

Reputation: 13515

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'.

Upvotes: 0

Timothy Rylatt
Timothy Rylatt

Reputation: 7860

Before you write code for this you need to break the task down into steps.

  1. Open one of the documents that you need to apply the changes to.
  2. Record a macro whilst you edit the Header style so that it has the correct formatting
  3. Record a macro whilst you edit the Footer style so that it has the correct formatting
  4. Edit the header of the document to include whatever logo and text you require.
  5. 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.
  6. 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.

Upvotes: 1

Related Questions