#1
|
|||
|
|||
Replace or apply new header in multiple files
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 |
#2
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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. |
#4
|
||||
|
||||
Quote:
Set wdDocSrc = ActiveDocument use: Set wdDocSrc = Documents.Open("C:\Users\" & Environ("Username") & "\Documents\source.docx", AddToRecentFiles:=False, Visible:=False)
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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.
|
#6
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
Works great! Thanks for the help.
|
#8
|
|||
|
|||
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. |
#9
|
|||
|
|||
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. |
#10
|
|||
|
|||
Quote:
|
#11
|
||||
|
||||
Quote:
Code:
.Range.FormattedText = _ wdDocSrc.Sections.First.Headers(HdFt.Index).Range.FormattedText Code:
wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Copy .Range.PasteAndFormat wdFormatOriginalFormatting
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#12
|
|||
|
|||
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.
|
#13
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#14
|
|||
|
|||
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 |
#15
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
macropod |
Thread Tools | |
Display Modes | |
|
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 |