Microsoft Office Forums - View Single Post - [Solved] Replace lines of text from header in multiple files

PolarPop · 05-25-2022, 01:20 PM

I've recently been tasked to update the header of over 500 word files. I originally used a macro provided from macropod to replace the header in each file with one from a separate file. That worked smoothly. But when comparing the files, it was discovered that many of them had other information in the header that wasn't supposed to be removed.

It was determined that only the first 3 lines of text in the header needs to be replaced. Each line of text is slightly different so a bulk "find and replace" won't work. Also the 3 lines in every document contain 52 characters, so I think I can use that. I'm thinking that the code can be modified to do what I need it to do, but I have no clue where to start.

Code:

Sub ReplaceDocumentHeaders()
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
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Copy
                                .Range.PasteAndFormat wdFormatOriginalFormatting
                                .Range.Characters.Last = vbNullString
                            ElseIf .LinkToPrevious = False Then
                                wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Copy
                                .Range.PasteAndFormat wdFormatOriginalFormatting
                                .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