Replace or apply new header in multiple files

Carchee · #1 04-29-2014, 12:40 PM

Our company has specification with our own headers and footers, however from time to time we are required to use a header and footer not of our own. It becomes tedious to open each file and delete the header and replace it with the new one. I can't simply do a find and replace because the format of the header is always completely different.

Any ideas on how to change headers in multiple files? I received code a while back from macropod which would find and replace text within headers with multiple files which works great. I was thinking it would be similar but not sure how to alter the code. Also how do I keep the original formatting such as text size and font from the source?

I have set it up with the use of forms.
The following code is what I received from macropod, but it has been altered for my application.

Code:

Private Sub cbOptionOK_Click()

Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim strFnd As String, strRep As String, wdStory(), i As Long

'Cue function to select folder where files are found

strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)

Select Case cboHFList.Value

Case "Replace Header"



'******************************************************

Case "Edit text within header"

'Input text
strFnd = InputBox("Text to Replace", "Old String", "Water Feature Facility")
If strFnd = "" Then Exit Sub
strRep = InputBox("Replacement Text", "New String")
If strRep = "" Then Exit Sub

wdStory = Array(wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    On Error Resume Next
    For i = LBound(wdStory) To UBound(wdStory)
      'MsgBox wdStory(i)
      With .StoryRanges(wdStory(i)).Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strFnd
        .Replacement.Text = strRep
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
      End With
    Next
    On Error GoTo 0
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True


Private Sub UserForm_Initialize()

    cboHFList.AddItem "Replace header"
    cboHFList.AddItem "Edit text within header"


End Sub

'Function to select folder where files are found

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

macropod · #2 04-29-2014, 03:14 PM

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

Carchee · #3 04-30-2014, 09:03 AM

The code does exactly what it needs to and works great.

Is there a way to create another function using the "CreateObject" or "GetObject" that selects the source file and sets the wdDocSrc to the chosen file rather than copying and pasting the code into the source file? I have been trying to do this all morning and haven't been successful.

macropod · #4 04-30-2014, 03:04 PM

Quote:

Originally Posted by Carchee

Is there a way to create another function using the "CreateObject" or "GetObject" that selects the source file and sets the wdDocSrc to the chosen file rather than copying and pasting the code into the source file?

That's not how you'd go about it. Rather, you'd simply use another of the 'Documents.Open' procedures. For example, instead of:
Set wdDocSrc = ActiveDocument
use:
Set wdDocSrc = Documents.Open("C:\Users\" & Environ("Username") & "\Documents\source.docx", AddToRecentFiles:=False, Visible:=False)

Carchee · #5 04-30-2014, 03:42 PM

Okay I see how that would work if the source file was always in that specific spot, however the source file will be in different folders each time. So it would be nice if the user could pick where the source file is located just like the user picked where the folder containing the target files are.

macropod · #6 04-30-2014, 04:02 PM

In that case, you could use:

Code:

    With Application.Dialogs(wdDialogFileOpen)
      If .Show = -1 Then
        Set wdDocSrc = ActiveDocument
      Else
        MsgBox "No Source document chosen. Exiting", vbExclamation
        Exit Sub
      End If
    End With

Carchee · #7 05-01-2014, 07:56 AM

Works great! Thanks for the help.

Carchee · #8 05-01-2014, 08:57 AM

Now getting more complex now, at least for me, okay lets be honest all this is complex for me but I'm learning.

The source header is single spaced and has 0 pt before and after lines, however after the the source header is pasted the line spacing is changed to 10 pt after lines. I noticed it does this if I manually copy and paste.

Charles Kenyon · #9 05-01-2014, 02:42 PM

One completely different method is to store the headers and footers in a template as AutoText and use AutoText fields to incorporate them.

To change them wholesale, simply load a different Add-In template containing the AutoText you want.

This would require revamping everything, but if you do this often you might want to consider it.

I am a stringer for a national law firm and when I do work for them, I simply change my loaded AutoText holder and all of my forms change to show that firm's information. It is work to set up, but a piece of cake to make the switch when needed.

I also did this when I worked for a lawfirm with more than 50 local offices that needed local information in their (otherwise uniform) letterhead and forms. In that case, it was bits and pieces of the headers rather than the whole header.

P.S. If you use this method, document it VERY WELL or you will make some people very upset when you are not around.

Charles Kenyon · #10 05-01-2014, 02:44 PM

Quote:

Originally Posted by Carchee

Now getting more complex now, at least for me, okay lets be honest all this is complex for me but I'm learning.

The source header is single spaced and has 0 pt before and after lines, however after the the source header is pasted the line spacing is changed to 10 pt after lines. I noticed it does this if I manually copy and paste.

You would need to be transferring in the Style as well. The default is to use the existing Style in the receiving document/template.

macropod · #11 05-01-2014, 02:55 PM

Quote:

Originally Posted by Carchee

The source header is single spaced and has 0 pt before and after lines, however after the the source header is pasted the line spacing is changed to 10 pt after lines. I noticed it does this if I manually copy and paste.

Evidently, then, someone is overriding the Style definitions, with manual formatting. If the Styles were being used properly, that wouldn't be an issue. You could try replacing:

Code:

.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText

with:

Code:

wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Copy
.Range.PasteAndFormat wdFormatOriginalFormatting

Carchee · #12 05-05-2014, 12:39 PM

The .Copy gives a compile error. Also instead of simply copying your code I wrote it from scratch to get the pop ups and selected the appropriate ones and it still gives me the code.

macropod · #13 05-05-2014, 03:47 PM

I am unable to reproduce that error. You can demonstrate that there's nothing wrong with that line by running the following macro in a scratch document:

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

This code simply copies the header content to the footer in the same document. What particular error message are you getting?

Carchee · #14 05-06-2014, 08:25 AM

I get a Compile error: Expected Function or variable

It highlights the .Copy in blue. The help says I am trying to inappropriately assign a value to a procedure name.

The following is my code. I have it set up with userforms and Case's so you won't be able to run it but at least you can see it as a whole. I see no reason why this code shouldn't work.

Code:

Private Sub cbOptionOK_Click()
 
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim strFnd As String, strRep As String, wdStory(), i As Long
Dim wdDocTgt As Document, wdDocSrc As Document
Dim Sctn As Section, HdFt As HeaderFooter
 
'Cue function to select folder where specification files are found
 
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
 
Unload Me
 
Select Case cboHFList.Value
 
Case "Replace header"
 
      With Application.Dialogs(wdDialogFileOpen) 'Open header source file
      If .Show = -1 Then
        Set wdDocSrc = ActiveDocument
      Else
        MsgBox "No Source document chosen. Exiting", vbExclamation
        Exit Sub
      End If
    End With
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
        Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
        AddToRecentFiles:=False, Visible:=False)
        With wdDocTgt
            For Each Sctn In .Sections
                For Each HdFt In Sctn.Headers
                    With HdFt
                        If .Exists Then
                            If .LinkToPrevious = False Then
                                .Range.FormattedText = _
                                wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.Copy
                                wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.PasteAndFormat wdFormatOriginalFormatting
                            End If
                        End If
                    End With
                Next
            Next
            .Close SaveChanges:=True
        End With
                strFile = Dir()
    Wend
    Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
    Application.ScreenUpdating = True

macropod · #15 05-06-2014, 04:32 PM

There is a perfectly good reason it wouldn't work. You're using something quite different from what I advised in post #11: https://www.msofficeforums.com/word-...html#post63089

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