Consulting

Results 1 to 12 of 12

Thread: Macro to modify header in multiple word documents

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Newbie
    Joined
    Apr 2014
    Posts
    4
    Location

    Macro to modify header in multiple word documents

    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

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    VBAX Newbie
    Joined
    Apr 2014
    Posts
    4
    Location
    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
    Attached Files Attached Files

  4. #4
    VBAX Newbie
    Joined
    Apr 2014
    Posts
    4
    Location
    Here is the header that I am trying to update the document to.
    Attached Files Attached Files

  5. #5
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  6. #6
    VBAX Newbie
    Joined
    Apr 2014
    Posts
    4
    Location
    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

    Quote Originally Posted by macropod View Post
    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

  7. #7
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by lapo1234 View Post
    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.
    Quote Originally Posted by lapo1234 View Post
    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.

    Quote Originally Posted by fumei View Post
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  8. #8
    VBAX Wizard
    Joined
    May 2004
    Posts
    6,713
    Location
    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)

  9. #9
    VBAX Wizard
    Joined
    May 2004
    Posts
    6,713
    Location
    I should learn not to post at 4:00 am.....brain fart....

  10. #10
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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.
    Attached Files Attached Files

  11. #11
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by snb View Post
    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???
    Quote Originally Posted by lapo1234 View Post
    some of the information contained in the original header we would like to retain, like document number and document title.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  12. #12
    VBAX Wizard
    Joined
    May 2004
    Posts
    6,713
    Location
    save that file as G:\OF\__newheader.docx"
    Not such a great instruction if the person does not have a G: drive...

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •