Sub Demo()
Application.ScreenUpdating = False
Dim s As Long, Rng As Range
With ActiveDocument
  For s = .Sections.Count To 1 Step -1
    With .Sections(s)
      Set Rng = .Range: Rng.End = Rng.End - 1
      Rng.Find.Execute FindText:=Chr(12), Replacewith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
      If s = 1 Then Exit Sub
      If .PageSetup.SectionStart <> wdSectionContinuous Then .Range.Characters.Last.Delete
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub