Replace lines of text from header in multiple files

PolarPop · #1 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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Replace or apply new header in multiple files	Carchee	Word VBA	42	07-10-2024 08:47 AM
Doc with autoformatted lines not printing text or header - only lines	klunsford11	Word	2	08-07-2020 09:12 PM
VBA to find text, replace with multiple lines of text	noslenwerd	Word VBA	3	12-31-2019 11:04 AM
Find and replace header text across multiple files	LG1972	Excel	1	12-25-2018 04:27 AM
Trying to add space between lines of bulleted text and a new header but both lines are moving???	Martin_d35	Word	2	02-10-2017 07:13 AM