Bulk Removal of Paragraph Mark in Header

ladracer · #1 07-07-2022, 06:52 AM

I have a folder containing more than 500 documents, each with a header that has some text followed by 3 paragraph marks. I am looking to reduce that to only the text followed by 2 paragraph marks. Thought it would be fairly simple, but it has proved difficult for me. I have tried Chr(13) and ^p without success. Tried a bevy of different iterations. Please help.

Sub ReplaceHeaderTextInFolder2()
'
Dim objDoc As Document
Dim strFile As String
Dim strFolder As String
Dim strFindText As String
Dim strReplaceText As String
Dim xSelection As Selection
Dim xSec As Section
Dim xHeader As HeaderFooter

' Pop up input boxes for user to enter folder path, the finding and replacing texts.
strFolder = InputBox("Enter folder path here:")
strFile = Dir(strFolder & "" & "*.docx", vbNormal)
strFindText = "^p^p^p"
strReplaceText = "^p^p"

' Open each file in the folder to search and replace texts. Save and close the file after the action.
While strFile <> ""
Set objDoc = Documents.Open(FileName:=strFolder & "" & strFile)
With objDoc
For Each xSec In objDoc.Sections

For Each xHeader In xSec.Headers
xHeader.Range.Select
Set xSelection = objDoc.Application.Selection
With xSelection
.HomeKey Unit:=wdStory

With xSelection.Find
'.Text = strFindText
'.Replacement.Text = strReplaceText

.Text = strFindText
.Replacement.Text = strReplaceText

.Forward = True
.Wrap = wdFindContinue
'.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

End With
xSelection.Find.Execute Replace:=wdReplaceAll
End With
Next xHeader
Next xSec
objDoc.Save
objDoc.Close
strFile = Dir()
End With
Wend

End Sub

mark99k · #2 07-07-2022, 01:15 PM

Having a macro create a selection in a header is iffy at best (and if you ever actually need it, a better way is ActiveWindow.View.SeekView). Here, though, you're better off replacing your entire second loop with just this:

Code:

For Each xHeader In xSec.Headers
    xHeader.Range.Find.Execute FindText:="^p^p^p", ReplaceWith:="^p^p", Replace:=wdReplaceAll
Next xHeader

macropod · #3 07-07-2022, 03:47 PM

Quote:

Originally Posted by mark99k

Having a macro create a selection in a header is iffy at best (and if you ever actually need it, a better way is ActiveWindow.View.SeekView).

Using Selection is simply inefficient and unnecessary. As is using ActiveWindow.View.SeekView.

The following macro will process all Headers in all Sections of all Documents in both the chosen folder and its sub-folders.

Code:

Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String, wdDocSrc As Document, wdDocTgt As Document

Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
If TopLevelFolder = "" Then Exit Sub
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
Set wdDocSrc = ActiveDocument
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
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

Sub UpdateDocuments(oFolder As String)
Dim strInFolder As String, strFile As String, Sctn As Section, HdFt As HeaderFooter
strInFolder = oFolder
strFile = Dir(strInFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDocTgt = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDocTgt
    For Each Sctn In .Sections
      For Each HdFt In Sctn.Headers
        With HdFt
          If .Exists Then .Range.Find.Execute FindText:="[^13]{3,}", ReplaceWith:="^p^p", MatchWildcards:=True, Replace:=wdReplaceAll
        End With
      Next
    Next
    'Save and close the document
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
End Sub

ladracer · #4 07-08-2022, 05:37 AM

Mark and Paul thank you for your assistance in this matter.

It is greatly appreaciated.

Interestingly, neither of the macros worked, initially.

One, likely important facet I failed to mention (as I did not know it would make a difference) and is the likely culprit for the failure to work as desired was that the 3 paragraphs that I am attempting to replace with 2 are at the end of the header.

However, both macros worked when I made substitutions (^p^p for ^p^p^p and ^p for ^p^p in Mark's code and "[^13]{2,}", ReplaceWith:="^p" in Paul's code). That is when I replaced two paragraph marks with one.

However, that does not technically solve my initial problem as some of the documents may have only 2 paragraph marks in the header and if I use the adulterated code above it would mess those documents up.

So what I should have asked from the beginning is: Is there a means to check for 3 paragraphs when they are the last 3 entries in a header?

macropod · #5 07-08-2022, 06:14 AM

You could just change:
FindText:="[^13]{3,}"
to:
FindText:="[^13]{2,}"
and leave:
ReplaceWith:="^p^p"
alone.

Alternatively, you might modify the Dim line at the top of the UpdateDocuments sub, thus:

Code:

Dim strInFolder As String, strFile As String, Sctn As Section, HdFt As HeaderFooter, Rng As Range

and change:

Code:

        With HdFt
          If .Exists Then .Range.Find.Execute FindText:="[^13]{3,}", ReplaceWith:="^p^p", MatchWildcards:=True, Replace:=wdReplaceAll
        End With

to:

Code:

        With HdFt
          If .Exists Then
            Set Rng = .Range.Characters.Last
            With Rng
              Do While .Start > HdFt.Range.Start
                If .Characters.First.Previous = vbCr Then
                  .Start = .Start - 1
                Else
                  Exit Do
                End If
              Loop
              If .Paragraphs.Count > 2 Then .Text = vbCr & vbCr
            End With
          End If
        End With

ladracer · #6 07-08-2022, 06:48 AM

Paul, the first suggestion did not seem to work...seems it does not recognize the last paragraph mark....so I made the suggested substitution.

Unfortunately, it threw an error code.

Run-time error '91'
Object variable or With block variable not set

when I went to the debug screen the following was highlighted.

Set Rng = Rng.Characters.Last

The complete code is below.

Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String, wdDocSrc As Document, wdDocTgt As Document

Sub ReplaceParagraphsInHeader()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
If TopLevelFolder = "" Then Exit Sub
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If
Set wdDocSrc = ActiveDocument
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
RecurseWriteFolderName (SubFolder)
Next
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

Sub UpdateDocuments(oFolder As String)
Dim strInFolder As String, strFile As String, Sctn As Section, HdFt As HeaderFooter, Rng As Range
strInFolder = oFolder
strFile = Dir(strInFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDocTgt = Documents.Open(FileName:=strInFolder & "" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDocTgt
For Each Sctn In .Sections
For Each HdFt In Sctn.Headers
With HdFt
If .Exists Then
Set Rng = Rng.Characters.Last
With Rng
Do While .Characters.First.Previous = vbCr
.Start = .Start - 1
Loop
If .Paragraphs.Count > 2 Then .Text = vbCr & vbCr
End With
End If
End With
Next
Next
'Save and close the document
.Close SaveChanges:=True
End With
strFile = Dir()
Wend
End Sub

Italophile · #7 07-08-2022, 10:13 AM

It errors because Rng hasn’t been set to anything.

Change to:

Code:

Set Rng = HdFt.Range.Characters.Last

ladracer · #8 07-08-2022, 10:59 AM

Italophile thanks for joining the discussion.

I tried your suggestion and it worked a bit farther into the code.

It now throws the same error on the line of:

Do While .Characters.First.Previous = vbCr

I tried: Do While HdFt.Characters.First.Previous = vbCr

and

Do While HdFt.Range.Characters.First.Previous = vbCr

but neither worked.

macropod · #9 07-08-2022, 03:58 PM

See the updated code revision in post #5.

PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it has.

ladracer · #10 07-08-2022, 04:56 PM

Thank you sir for all of your assistance.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
a macro to replace paragraph mark with a space applies effect on paragraph marks after the selection	drrr	Word VBA	2	08-24-2021 03:05 AM
What is this paragraph mark called	booneyrex	Word	8	03-04-2021 04:15 AM
Indention below paragraph mark...	kikola	Word VBA	13	05-26-2020 06:21 AM
Please help with header and footer removal	pwangdel	Word	3	11-03-2011 06:10 AM
Final paragraph mark	Caroline	Word	2	02-22-2011 10:39 AM