Replace or apply new header in multiple files

amanders0n · #31 03-08-2023, 12:11 PM

Quote:

Originally Posted by macropod

For what you describe, you could use a macro like the following. Simply add the macro to a document with your new header:

Code:

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 Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            End If
                        End If
                    End With
                Next
                'For footers
                For Each HdFt In Sctn.Footers
                    With HdFt
                        If .Exists Then
                            If Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            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'.

--
Hello, I am trying to use the code quoted above. I will preface by saying I am a complete VBA noob and do not know much about VBA coding.

I have a header that has 3 columns. The first (leftmost) column is the one I want to update, and that header column has 3 rows that all need to be updated to the same thing across all files. I have one file that has this updated, and I copied the macro above into that document.

However, when I run the code, I get the following error: "Run-time error '5937': Cannot copy content between these two ranges."

Debugging tells me that this is the problematic code: .Range.FormattedText = _
wdDocSrc.Sections.First.Headers(HdFt.Index).Range. FormattedText

Help please...

Charles Kenyon · #32 03-11-2023, 08:42 PM

Just a note that you seem to be describing a Table column.

kykyryky · #33 01-25-2024, 04:32 AM

Hello,

first of all, thank you for putting this useful thing together.

Yet it does not work for me. What I do:
1. Create a .bas file with the text stated above:

Code:

Attribute VB_Name = "Update_headers_footers"
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 Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            End If
                        End If
                    End With
                Next
                'For footers
                For Each HdFt In Sctn.Footers
                    With HdFt
                        If .Exists Then
                            If Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            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

2. left alt+F11, import, save, open macros:

3. then it prompts me to select a folder for some reason, I pick the one with the file(s) and then - nothing happens.

Tried this one mentioned above which copies the header to footer, which works just fine.

Misght I ask for a help, please? I am practically illiterate when it comes to scripting. Only using macros I get hold of.

Thank you!

EDIT:
1. It works when the file is saved on local. Can this be adjsuted somehow, please?
2. It does not do exactly what wanted. It is messed up. Will have the time to create a non-confidential document and upload sample details later.

macropod · #34 01-25-2024, 05:23 AM

There is no need for the .bas file. Simply press Alt-F11 then insert the code into the appropriate code module (e.g. 'ThisDocument').

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

kykyryky · #35 01-25-2024, 08:24 AM

Thank you. Yet this is a bit confusing to me, honestly. Looking for where to paste it and such.

Anyway:

1. This (header to footer) seemed to work before, yet now the same code gives me an error.

Code:

Sub Test()
Dim wdDocTgt As Document, wdDocSrc As Document
Set wdDocSrc = ActiveDocument
wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.Copy
wdDocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range.PasteAndFormat wdFormatOriginalFormatting
End Sub

Both for dummy files and our corporate ones. Any idea, please? I am not aware of changing anything from the time it worked these several hours ago.

Edit: Seems not/to work randomly on exactly the same files, machine, everyhing.

2. This (header to other docs) does not do anything if on a mapped network drive (simply nothing happens), and somehow (so far incorrectly, more later) works on local. Can this be solved in some manner, please? Could it be due to access restrictions/authentication? Yet me myself, I do have access with full rights there in the folders.

Code:

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrTxt As String
Dim wdDocTgt As Document, wdDocSrc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
StrTxt = InputBox("Text to add to headers? e.g. ""March 1, 2018""")
If Trim(StrTxt) = "" 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
            .Sections(1).Headers(wdHeaderFooterPrimary).Range.InsertAfter StrTxt
            .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

Once again, huge thanks for doing this.

macropod · #36 01-25-2024, 02:36 PM

The test code you're using merely copies & pastes the active document's primary header over its footer. It will produce an error if there's no primary header.

The UpdateDocumentHeaders code you posted doesn't replicate anything; all it does is add whatever you've typed at the InputBox prompt to the primary header of all documents in the selected folder.

kykyryky · #37 01-26-2024, 12:14 AM

Yes, I know.

kykyryky · #38 01-26-2024, 02:17 AM

Hello, so tried running this header/footer copy from > to on the same pair of two docs. One with a header (called source) and one without (called victim).

When ran on a local C: drive, works just fine.
When ran on a mapped network drive U:, does nothing:

Can this be solved? Thank you!

Secondly, when running this header > footer (as a test), it shows an error:

Any idea, please?

Many thanks!

kykyryky · #39 01-26-2024, 02:33 AM

the file uploaded here.

kykyryky · #40 01-26-2024, 02:58 AM

And if you would not mind me asking yet another question at the same time...

Here I took a source with a header and footer and wanted them to be copied into a victim with a different set. As seen here:

and ran the code with no change. Worked "quite nice":

As you can see, they are not completely the same. The sizing of the text went from 9 to 11, the butterfly picture went down to the line, the whole footer went up and left.

The change is not a function of the target style. Look, here I used a very wild set of properties for the victim, yet the result is the same as above.

Also, I noticed that the copied picture is not the same "object" as the source. Look:

If you are accepting donations, I will gladly donate for your help.

kykyryky · #41 01-26-2024, 03:00 AM

And yes, the files here, if it helps...

Italophile · #42 01-26-2024, 07:27 AM

Quote:

Originally Posted by kykyryky

And yes, the files here, if it helps...

The page layout of the two files is different, which accounts for the header appearing in a different place.

Although the text in the header of the source document states that it is in 9pt, it is actually 11pt, so it isn't any different after copying.

awhoughton · #43 07-10-2024, 08:47 AM

Quote:

Originally Posted by macropod

For what you describe, you could use a macro like the following. Simply add the macro to a document with your new header:

Code:

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 Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            End If
                        End If
                    End With
                Next
                'For footers
                For Each HdFt In Sctn.Footers
                    With HdFt
                        If .Exists Then
                            If Sctn.Index = 1 Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Footers(HdFt.Index).Range.FormattedText
                                .Range.Characters.Last = vbNullString
                            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'.

What needs to change if I want all the .doc AND .docx files in a folder to be updated?

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Find & Replace in Header/Footer in 1000 files	amodiammmuneerk@glenmarkp	Word	12	03-05-2018 03:31 AM
Find & Replace in Header/Footer	PReinie	Word	6	01-22-2014 06:45 PM
How to apply a list style to multiple Word documents?	MrSnrub	Word	4	06-19-2013 07:32 AM
Apply template to multiple documents	Oliver Beirne	Word VBA	2	04-24-2012 04:49 AM
convert multiple csv files to multiple excel files	mit	Excel	1	06-14-2011 10:15 AM