Bulk Removal of Paragraph Mark in Header

[ladracer]

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