Macro to modify header in multiple word documents

[lapo1234]

My company was acquired and there are several documents that we would like to change the format of the header, across multiple sections of a document. However, some of the information contained in the original header we would like to retain, like document number and document title. Is there anyway to replace the current header with the header of the new company, which has an image it in, while keeping certain manually entered data?

Thank you in advance

[macropod]

Yes, it's possible, but you haven't provided any details as to how the data you want to keep can be differentiated from the data you want to replace. You mention multiple Sections, but not which header (every Section has three) and whether, for the headers you want to update, each Section's header is linked to the previous Section's header.

Here's some code to get you started:

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDoc As Document, Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
AddToRecentFiles:=False, Visible:=False)
With wdDoc
For Each Sctn In .Sections
'Assuming every header in every Section is to be processed
For Each HdFt In Sctn.Headers
With HdFt
If .LinkToPrevious = False Then
'Process the header here
End If
End With
Next
Next
.Close SaveChanges:=True
End With
strFile = Dir()
Wend
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
The macro includes its own folder browser, so all you need do is point it to the folder to be processed. As coded, it doesn't actually do anything, because you haven't hiven the required details.

[lapo1234]

Attached is an example of the current header. I will attach an example of what I want it to look like in a follow up post. As mentioned there are multiple sections in the document so the macro needs to go through all sections of the document to change the header.

Thanks

[lapo1234]

Here is the header that I am trying to update the document to.

[macropod]

For what's indicated in your attachments, add the following macro to your 'new header' document. Do not store that file in the folder to be processed:

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrRef As String, StrTtl As String
Dim wdDocTgt As Document, wdDocSrc As Document, Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
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 .LinkToPrevious = False Then
If .Range.Tables.Count = 1 Then
With .Range.Tables(1).Range
StrRef = Split(Split(.Cells(2).Range.Text, ":")(1), Chr(13))(0)
StrTtl = Split(Split(.Cells(7).Range.Text, ":")(1), Chr(13))(0)
End With
.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
With .Range.Tables(1).Range
.Cells(2).Range.InsertAfter StrRef
.Cells(4).Range.InsertAfter StrTtl
End With
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
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

[lapo1234]

Thank you for the quick reply. What do I need to modify in this script to make it change the headers in the correct folder? It asks me to select a folder but does not seem to do anything once I select one.

Thanks


For what's indicated in your attachments, add the following macro to your 'new header' document. Do not store that file in the folder to be processed:

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrRef As String, StrTtl As String
Dim wdDocTgt As Document, wdDocSrc As Document, Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
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 .LinkToPrevious = False Then
If .Range.Tables.Count = 1 Then
With .Range.Tables(1).Range
StrRef = Split(Split(.Cells(2).Range.Text, ":")(1), Chr(13))(0)
StrTtl = Split(Split(.Cells(7).Range.Text, ":")(1), Chr(13))(0)
End With
.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
With .Range.Tables(1).Range
.Cells(2).Range.InsertAfter StrRef
.Cells(4).Range.InsertAfter StrTtl
End With
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
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

[fumei]

It asks me to select a folder but does not seem to do anything once I select one.
Is it possible that the files you want processed are docx? The code looks for only doc files. If this is the case change:

strFile = Dir(strFolder & "\*.doc", vbNormal)

to

strFile = Dir(strFolder & "\*.docx", vbNormal)

[macropod]

What do I need to modify in this script to make it change the headers in the correct folder?
All you need do is select the folder to process.

It asks me to select a folder but does not seem to do anything once I select one.
Did you look at the files after running the macro?

PS: Please don't quote entire posts in your replies; quote only those parts you actually need to cite.


Is it possible that the files you want processed are docx? The code looks for only doc files.
Not so! Using:
strFile = Dir(strFolder & "\*.doc", vbNormal)
finds .doc, .docx and .docm files. All you'll achieve by changing .doc to .docx is to exclude .doc & .docm files from processing.

[fumei]

I should learn not to post at 4:00 am.....brain fart....

[snb]

You could:

- put the new header in a worddocument
- bookmark that new header
- save that file as G:\OF\__newheader.docx"

In every document that should have headers you can insert an 'INCLUDETEXT' field, linked to the bookmark in the file G:\OF\__newheader.docx"

For examples see the attachment.
In the attachment in the _currentheader document you will find some VBA how to add the includetext field into header storyranges.
In future you only have to adapt the '__newheader' file. All documents that are linked to this file can be updated automatically.

[macropod]

You could:

- put the new header in a worddocument
- bookmark that new header
- save that file as G:\OF\__newheader.docx"
And how is that going to retain the data the OP wants to keep???

some of the information contained in the original header we would like to retain, like document number and document title.

[fumei]

save that file as G:\OF\__newheader.docx"
Not such a great instruction if the person does not have a G: drive...