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