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

macropod · #2 05-25-2022, 04:45 PM

Try something along the lines of:

Code:

Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
Dim wdRngSrc As Range, wdRngTgt As Range
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
                                Set wdRngTgt = .Range.Characters.First
                                wdRngTgt.End = wdRngTgt.End + 51
                                Set wdRngSrc = wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Characters.First
                                wdRngSrc.End = wdRngSrc.End + 51
                                wdRngTgt.FormattedText = wdRngSrc.FormattedText
                            ElseIf .LinkToPrevious = False Then
                                Set wdRngTgt = .Range.Characters.First
                                wdRngTgt.End = wdRngTgt.End + 51
                                Set wdRngSrc = wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Characters.First
                                wdRngSrc.End = wdRngSrc.End + 51
                                wdRngTgt.FormattedText = wdRngSrc.FormattedText
                            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

PolarPop · #3 05-25-2022, 08:11 PM

So, for my understanding, you defined two ranges that cover the number of characters in the target and the number of characters in the template (screen). And then the macro is replacing the target with the screen. This is awesome!

Is it possible to do this with lines, paragraphs or some combination (characters in the target document and paragraphs in the screen document) or does the character count make it the easiest? And does the character count for each document have to match?

Guessed · #4 05-25-2022, 08:39 PM

It is possible to do it accurately with paragraphs or characters. Paul coded it according to the information you gave him.

Unfortunately, Word isn't good with 'lines' because that is a liquid concept because of column width, font size, typeface etc. So when you specified 3 lines we don't know exactly what that means.

The source and target ranges can be defined in terms of paragraphs or characters - both are independent of each other.

PolarPop · #5 05-25-2022, 09:17 PM

What Mr. Edstein did is perfect. I wish I knew a fraction of what he does. I have searched this forum in the past and the solutions he comes up with over and over again are amazing. I meant no offense.

I just want to understand what the possibilities are and how I can utilize it in other ways. I want to learn how it works so if my character count was off or changes in the future, I can modify the solution that was provided.

For clarification, in my documents, 3 lines would be closely defined as 3 rows. The first is document number, the second is the document effective date, and the third is the page number (page x of y). Each line ends with a ^p. I now realize that may run into an issue where longer documents would have 53 characters versus the number 52 that I provided.

What does this do?

Code:

wdRngTgt.FormattedText = wdRngSrc.FormattedText

macropod · #6 05-26-2022, 07:53 AM

Quote:

Originally Posted by PolarPop

For clarification, in my documents, 3 lines would be closely defined as 3 rows. The first is document number, the second is the document effective date, and the third is the page number (page x of y). Each line ends with a ^p.

That means you have 3 paragraphs, not merely a paragraph of 3 lines, in which case -and assuming you want to replace those 3 paragraphs - you could use:

Code:

                                Set wdRngTgt = .Range.Paragraphs.First
                                wdRngTgt.MoveEnd wdParagraph, 2
                                Set wdRngSrc = wdDocSrc.Sections.First.Headers(HdFt.Index).Range.Paragraphs.First
                                wdRngSrc.MoveEnd wdParagraph, 2
                                wdRngTgt.FormattedText = wdRngSrc.FormattedText

Quote:

Originally Posted by PolarPop

What does this do?

Code:

wdRngTgt.FormattedText = wdRngSrc.FormattedText

This does essentially the same as a copy/paste that preserves the source formatting, but without using the clipboard.

PolarPop · #7 05-27-2022, 01:43 PM

Thank you for taking the time to explain this and for all of your help! I have learned so much from reading your posts on this and many other questions.

Thanks again!

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