Replace or apply new header in multiple files

Carchee · #1 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 · #2 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

Afrederick · #3 02-17-2022, 12:22 PM

Hello macropod,

Your script here works nearly perfectly for something I am trying to achieve, and I was hoping you could give me a tip on an issue I am facing.

I have a source document with headers and footers that I want to push to a whole folder of word documents. The issue is that in some of the word documents that are receiving the new headers/footers have a table in the footer. For example some have a 1 row, 2 column table in the footer to show the page title and project number respectively. When I run the script you wrote (which works exactly how it is written) it doesnt remove the table and replace it with the source footer. Instead it just removes all the text and replaces it with the source text. This causes extra spacing and formatting issues since is extra spacing with the tables.

If you have any tips I would greatly appreciate it. Thank you!

kykyryky · #4 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.

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